C
C     This code is distributed under the terms and conditions of the
C     CCP4 licence agreement as `Part i)' software.  See the conditions
C     in the CCP4 manual for a copyright statement.
C
C
C     Note that *writing* of LCF files is now disabled.  This was done
C     with a quick hack.  Quite a bit of the code should be commented
C     out (even if, for instance, the `exchange' program isn't touched).
C     
C SUBROUTINE 'CELCF1'
C ===================
C
C TRANSLATE BETWEEN TWO 2 BYTE INTEGER VALUES AND A FLOATING POINT
C NUMBER  (FOR PACKING/UNPACKING CELL DIMENSIONS IN HEADER RECORDS)
C
C ****THIS SUBROUTINE CONTAINS MACHINE CODE****
C
      SUBROUTINE CELCF1(IDATA,N,CELL,IRW)
C
C PARAMETERS
C
C      IDATA    ARRAY CONTAINING THE INTEGER VALUES
C          N    THE POSITION IN 'IDATA' OF THE FIRST NUMBER
C       CELL    THE FLOATING POINT VALUE
C        IRW    =1 TRANSLATE FROM INTEGER VALUES TO FLOATING POINT
C               =2 TRANSLATE FROM FLOATING POINT TO INTEGER VALUES
C
C SPECIFICATION STATEMENTS AND CODE
C ---------------------------------
C
      DIMENSION IDATA(*)
      INTEGER*2 KDATA(2)
      EQUIVALENCE (X,KDATA(1))
      GO TO(10,20),IRW
10    KDATA(1)=IDATA(N)
      KDATA(2)=IDATA(N+1)
      CELL=X
      RETURN
20    X=CELL
      IDATA(N)=KDATA(1)
      IDATA(N+1)=KDATA(2)
      RETURN
      END
C
C SUBROUTINE 'CELCF2'
C ===================
C
C TRANSLATE BETWEEN TWO 2 BYTE INTEGER VALUES AND A FLOATING POINT
C NUMBER  (FOR PACKING/UNPACKING CELL DIMENSIONS IN HEADER RECORDS)
C
C ****THIS SUBROUTINE CONTAINS MACHINE CODE****
C
      SUBROUTINE CELCF2(IDATA,N,CELL,IRW)
C
C PARAMETERS
C
C      IDATA    ARRAY CONTAINING THE INTEGER VALUES
C          N    THE POSITION IN 'IDATA' OF THE FIRST NUMBER
C       CELL    THE FLOATING POINT VALUE
C        IRW    =1 TRANSLATE FROM INTEGER VALUES TO FLOATING POINT
C               =2 TRANSLATE FROM FLOATING POINT TO INTEGER VALUES
C
C SPECIFICATION STATEMENTS AND CODE
C ---------------------------------
C
      DIMENSION IDATA(*)
      INTEGER*2 KDATA(2)
      EQUIVALENCE (X,KDATA(1))
      GO TO(10,20),IRW
10    KDATA(1)=IDATA(N)
      KDATA(2)=IDATA(N+1)
      CELL=X
      RETURN
20    X=CELL
      IDATA(N)=KDATA(1)
      IDATA(N+1)=KDATA(2)
      RETURN
      END
C
C SUBROUTINE 'CHLCF1'
C ===================
C
C THIS SUBROUTINE IS USED TO TRANSFER CHARACTERS TO AND FROM A
C REFLECTION DATA RECORD OF AN LCF FILE
C
C  ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
C VERSION FOR 2 CHARACTERS/COLUMN
C
      SUBROUTINE CHLCF1(IDATA,MIN,MAX,CHARR,NCH,LL,IRW,*)
C
C PARAMETERS
C
C       IDATA (I/O) INTEGER ARRAY FOR REFLECTION RECORD
C         MIN (I)   NO. OF FIRST COLUMN FOR CHARACTERS
C         MAX (I)   NO. OF FINAL COLUMN FOR CHARACTERS
C       CHARR (I/O) ARRAY WITH CHARACTER STRING
C         NCH (I)   MAX NO. OF CHARACTERS IN CHARR
C          LL (I/O) NO. OF LAST CHARACTER TRANSFERRED
C         IRW (I)   =1, TRANSFER FROM IDATA TO CHARR
C                   =2, TRANSFER FROM CHARR TO IDATA
C                       (PAD WITH SPACES)
C
C IF IRW=1  RETURN 1 IF ALL OF CHARR ARRAY READ
C IF IRW=2  RETURN 1 IF NO DATA TRANSFER PERFORMED
C
C SPECIFICATION STATEMENTS
C
      INTEGER IDATA(*)
      INTEGER*2 JDATA
      CHARACTER*1 CHARR(*)
      CHARACTER*2 CH
C
C SELECT OPTION
C
      GO TO(100,200),IRW
C
C COPY FROM RECORD BUFFER TO CHARACTER ARRAY
C
100   DO 120 M=MIN,MAX
      JDATA=IDATA(M)
      WRITE(CH,1000)JDATA
      DO 110 I=1,2
      LL=LL+1
      IF(LL.GT.NCH)RETURN 1
      CHARR(LL)=CH(I:I)
110   CONTINUE
120   CONTINUE
      IF(LL.EQ.NCH)RETURN 1
      RETURN
C
C COPY FROM CHARACTER ARRAY TO RECORD BUFFER
C
200   IF(LL.GE.NCH)RETURN 1
      DO 220 M=MIN,MAX
      CH='  '
      DO 210 I=1,2
      LL=LL+1
      IF(LL.GT.NCH)GO TO 210
      CH(I:I)=CHARR(LL)
210   CONTINUE
      READ(CH,1000)JDATA
      IDATA(M)=JDATA
220   CONTINUE
      RETURN
C
C FORMAT STATEMENTS
C
1000  FORMAT(A2)
      END
C
C SUBROUTINE 'CHLCF2'
C ===================
C
C THIS SUBROUTINE IS USED TO TRANSFER CHARACTERS TO AND FROM A
C REFLECTION DATA RECORD OF AN LCF FILE
C
C  ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
C VERSION FOR 2 CHARACTERS/COLUMN
C
      SUBROUTINE CHLCF2(IDATA,MIN,MAX,CHARR,NCH,LL,IRW,*)
C
C PARAMETERS
C
C       IDATA (I/O) INTEGER ARRAY FOR REFLECTION RECORD
C         MIN (I)   NO. OF FIRST COLUMN FOR CHARACTERS
C         MAX (I)   NO. OF FINAL COLUMN FOR CHARACTERS
C       CHARR (I/O) ARRAY WITH CHARACTER STRING
C         NCH (I)   MAX NO. OF CHARACTERS IN CHARR
C          LL (I/O) NO. OF LAST CHARACTER TRANSFERRED
C         IRW (I)   =1, TRANSFER FROM IDATA TO CHARR
C                   =2, TRANSFER FROM CHARR TO IDATA
C                       (PAD WITH SPACES)
C
C IF IRW=1  RETURN 1 IF ALL OF CHARR ARRAY READ
C IF IRW=2  RETURN 1 IF NO DATA TRANSFER PERFORMED
C
C SPECIFICATION STATEMENTS
C
      INTEGER IDATA(*)
      INTEGER*2 JDATA
      CHARACTER*1 CHARR(*)
      CHARACTER*2 CH
C
C SELECT OPTION
C
      GO TO(100,200),IRW
C
C COPY FROM RECORD BUFFER TO CHARACTER ARRAY
C
100   DO 120 M=MIN,MAX
      JDATA=IDATA(M)
      WRITE(CH,1000)JDATA
      DO 110 I=1,2
      LL=LL+1
      IF(LL.GT.NCH)RETURN 1
      CHARR(LL)=CH(I:I)
110   CONTINUE
120   CONTINUE
      IF(LL.EQ.NCH)RETURN 1
      RETURN
C
C COPY FROM CHARACTER ARRAY TO RECORD BUFFER
C
200   IF(LL.GE.NCH)RETURN 1
      DO 220 M=MIN,MAX
      CH='  '
      DO 210 I=1,2
      LL=LL+1
      IF(LL.GT.NCH)GO TO 210
      CH(I:I)=CHARR(LL)
210   CONTINUE
      READ(CH,1000)JDATA
      IDATA(M)=JDATA
220   CONTINUE
      RETURN
C
C FORMAT STATEMENTS
C
1000  FORMAT(A2)
      END
C
C SUBROUTINE 'CRLCF1'
C ===================
C
C THIS SUBROUTINE CLOSES AN INPUT LCF FILE
C
      SUBROUTINE CRLCF1
C
C PARAMETERS  NONE
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1WK/
      CALL QCLOSE (IUNIN)
      IUNIN=0
      RETURN
      END
C
C SUBROUTINE 'CRLCF2'
C ===================
C
C THIS SUBROUTINE CLOSES AN INPUT LCF FILE
C
      SUBROUTINE CRLCF2
C
C PARAMETERS  NONE
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2WK/
      CALL QCLOSE (IUNIN)
      IUNIN=0
      RETURN
      END
C
C
C SUBROUTINE 'CWLCF1'
C ===================
C
C THIS SUBROUTINE CLOSES AN OUTPUT LCF FILE
C
      SUBROUTINE CWLCF1
C
C PARAMETERS  NONE
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      INTEGER*2 IND(3)
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      EQUIVALENCE (IND(1),KDATA(1))
      SAVE /LCF1WK/
C
C Set terminator
      DO 1 I=1,3
1     IND(I)=32767
      CALL QWRITE(IUNOUT,IND,NCOUT)
      CALL QCLOSE (IUNOUT)
      RETURN
      END
C
C SUBROUTINE 'CWLCF2'
C ===================
C
C THIS SUBROUTINE CLOSES AN OUTPUT LCF FILE
C
      SUBROUTINE CWLCF2
C
C PARAMETERS  NONE
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      INTEGER*2 IND(3)
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      EQUIVALENCE (IND(1),KDATA(1))
      SAVE /LCF2WK/
C
C Set terminator
      DO 1 I=1,3
1     IND(I)=32767
      CALL QWRITE(IUNOUT,IND,NCOUT)
      CALL QCLOSE (IUNOUT)
      RETURN
      END
C
C
      SUBROUTINE GTORN1(IBATCH,IDATA)
C     ===============================
C
C This subroutine reads in the next set of orientation data into
C the common block 'ORIENT'.
C
C This version will cope with orientation data block of any length
C
C
C---- Parameters
C
C      IBATCH (O)   RETURNS THE BATCH NUMBER (-1 IF NO ORIENTATION
C                   BLOCK FOUND)
C       IDATA (I/O) ON INPUT HOLDS THE FIRST RECORD OF THE ORIENTATION
C                   BLOCK. DOES NOT CONTAIN THE FIRST RECORD AFTER
C                   THE ORIENTATION BLOCK ON RETURNING UNLESS IBATCH=-1
C
C---- Specification statements
C
      DIMENSION IDATA(*)
      LOGICAL RD
      COMMON /ORIENT/ORDATA(200)
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /ORIENT/,/LCF1WK/
C
C---- Read in orientation block
C
      LL=0
      ISEQ=0
10    IF(IDATA(1).NE.-32740)GO TO 100
      IBATCH=IDATA(5)
      IF(LL.EQ.0) NWORD=IDATA(7)
      ISEQ=ISEQ+1
      IF(ISEQ.NE.IDATA(6))GO TO 800
      CALL ORPAK1(IDATA,7,NCIN,ORDATA,NWORD,LL,1,*50)
      CALL RLCF1(IDATA,*810,*820)
      GO TO 10
C
C---- Block read
C
50    RETURN
C
C---- Not orientation data
C
100   IBATCH=-1
      RETURN
C
C---- Error conditions
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 800')
810   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 810')
820   WRITE(IOUT,2001)
      WRITE(IOUT,2004)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 820')
C
C---- Format statements
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(/,' **ORIENTATION DATA RECORDS OUT OF ORDER**')
2003  FORMAT(/,' **ERROR IN READING ORIENTATION DATA RECORDS**')
2004  FORMAT(/,' **END OF FILE WHEN READING ORIENTATION DATA**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'GTORN2'
C ===================
C
C THIS SUBROUTINE READS IN THE NEXT SET OF ORIENTATION DATA INTO
C THE COMMON BLOCK 'ORIENT'.
C   This version will cope with orientation data block of any length
C
      SUBROUTINE GTORN2(IBATCH,IDATA)
C
C PARAMETERS
C
C      IBATCH (O)   RETURNS THE BATCH NUMBER (-1 IF NO ORIENTATION
C                   BLOCK FOUND)
C       IDATA (I/O) ON INPUT HOLDS THE FIRST RECORD OF THE ORIENTATION
C                   BLOCK. DOES NOT CONTAIN THE FIRST RECORD AFTER
C                   THE ORIENTATION BLOCK ON RETURNING UNLESS IBATCH=-1
C
C SPECIFICATION STATEMENTS
C
      DIMENSION IDATA(*)
      COMMON /ORIENT/ORDATA(200)
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /ORIENT/,/LCF2WK/
C
C READ IN ORIENTATION BLOCK
C
      LL=0
      ISEQ=0
10    IF(IDATA(1).NE.-32740)GO TO 100
      IBATCH=IDATA(5)
      IF(LL.EQ.0) NWORD=IDATA(7)
      ISEQ=ISEQ+1
      IF(ISEQ.NE.IDATA(6))GO TO 800
      CALL ORPAK2(IDATA,7,NCIN,ORDATA,NWORD,LL,1,*50)
      CALL RLCF2(IDATA,*810,*820)
      GO TO 10
C
C BLOCK READ
C
50    RETURN
C
C NOT ORIENTATION DATA
C
100   IBATCH=-1
      RETURN
C
C ERROR CONDITIONS
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 800')
810   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 810')
820   WRITE(IOUT,2001)
      WRITE(IOUT,2004)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 820')
C
C FORMAT STATEMENTS
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(/,' **ORIENTATION DATA RECORDS OUT OF ORDER**')
2003  FORMAT(/,' **ERROR IN READING ORIENTATION DATA RECORDS**')
2004  FORMAT(/,' **END OF FILE WHEN READING ORIENTATION DATA**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C-- F77LCF      PCZ.F77LCF1.FORT                                28/02/85    JWC
C
C SUBROUTINE 'HDLCF1'
C ===================
C
C THE SUBROUTINE 'HDLCF1' IS USED TO SET UP FILE HEADER INFORMATION
C OR ADD FILE HEADER INFORMATION TO THAT ALREADY PRESENT AND,
C OPTIONALLY, TO WRITE THE HEADER RECORDS TO THE OUTPUT FILE VIA THE
C SUBROUTINE 'WHLCF1'
C
      SUBROUTINE HDLCF1(IUN,FILNAM,NT,ITITLE,NL,LABEL,CELL,IADD,IWRITE)
C
C PARAMETERS
C
C           IUN  (I)  UNIT NUMBER FOR OUTPUT FILE (0 TO LEAVE
C                     UNCHANGED)
C        FILNAM  (I)  LOGICAL FILE NAME (UP TO 8 CHARACTERS)
C                     (UNCHANGED IF IUN=0)
C            NT  (I)  THE NUMBER OF CHARACTERS OF TITLE INFORMATION TO
C                     BE ADDED (MAY BE 0)
C        ITITLE  (I)  CHARACTER ARRAY CONTAINING THE TITLE INFORMATION.
C                     THE SUBROUTINE WILL AUTOMATICALLY EXCLUDE
C                     TRAILING SPACES FROM THE TITLE INFORMATION
C                     ADDED.  THE USER SHOULD INSERT LEADING SPACES ETC.
C                     IF REQUIRED, TO SEPARATE ADDITIONAL TITLE
C                     INFORMATION FROM THE TITLE INFORMATION ALREADY
C                     PRESENT (UNLESS IADD=2).
C            NL  (I)  THE NUMBER OF CHARACTERS OF LABEL INFORMATION TO
C                     BE ADDED (MAY BE 0)
C         LABEL  (I)  CHARACTER ARRAY CONTAINING THE LABEL INFORMATION
C                     TO BE ADDED TO THE HEADER INFORMATION.
C                      THE SUBROUTINE WILL AUTOMATICALLY EXCLUDE
C                      REDUNDANT SPACES AND WILL SEPARATE THE NEW
C                     NEW LABELS FROM ANY EXISTING LABELS BY A SPACE.
C          CELL  (I)  THIS IS A SIX ELEMENT REAL ARRAY TO CONTAIN THE
C                     CELL DIMENSIONS FOR THE FILE HEADER.  THE CELL
C                     DIMENSIONS ARE INPUT AS A,B,C,ALPHA,BETA AND GAMMA
C                     IN ANGSTROMS AND DEGREES. IF CELL(1)=0.0, THEN
C                     THE EXISTING CELL DIMENSIONS SET UP IN THE
C                     HEADER WILL REMAIN UNCHANGED
C          IADD  (I)  FLAG =0, INITIALISE THE HEADER INFORMATION AND
C                              THEN ADD IN REQUIRED INFORMATION AS
C                              DEFINED BY THE PARAMETERS ABOVE.
C                          =1, ADD IN HEADER INFORMATION, AS DEFINED
C                              IN THE PARAMETERS ABOVE, TO ANY HEADER
C                              INFORMATION ALREADY PRESENT. (NOTE: CELL
C                              DIMENSIONS WILL BE REPLACED RATHER THAN
C                              ADDED)
C                          =2  AS FOR 1 BUT LEADING SPACE INSERTED
C                              BEFORE NEW TITLE INFORMATION
C                          =-1 REPLACE SOME OF TITLE, LABEL, OR CELL
C                              INFORMATION AS SPECIFIED BY NT, NL, AND
C                              CELL, BUT LEAVE OTHER HEADER INFORMATION
C                              UNCHANGED
C       IWRITE  (I)   FLAG =0, DO NOT WRITE THE HEADER INFORMATION TO
C                              THE FILE (USE THIS EXCEPT ON THE LAST
C                              CALL TO HDLCF1)
C                          =1, WRITE THE HEADER INFORMATION TO THE
C                              OUTPUT FILE
C
C SUBROUTINES CALLED 'LCFINC' 'LCFSHF' 'LCFITM' 'WHLCF1'
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD
      CHARACTER*(*) FILNAM
      CHARACTER*1 ARRAYN(1000),ITITLE(*),LABEL(*),ISP
      DIMENSION IDATA(1),CELL(6)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT
      COMMON /LCF1FN/FILIN,FILOUT
      SAVE /LCF1/,/LCF1AR/,/LCF1WK/,/LCF1FN/
      DATA ISP/' '/
C
C INITIALISE COMMON /LCF1WK/ IF REQUIRED
C
      CALL INLCF1(5,6,72)
C
C INITIALISE SOME COMMON AREA ENTRIES IF IADD=0
C
      MAXDN=1000
      IF(IADD.NE.0)GO TO 50
      DO 10 I=1,6
      CELLN(I)=0.0
10    CONTINUE
      DO 20 I=1,1000
      ARRAYN(I)=ISP
20    CONTINUE
      LTITN=0
      LABELN=0
      MAXDN=1000
      LRECLN=0
C
C SET FLAG FOR DDNAME IF SPECIFIED
C
50    IF(IUN.NE.0)IDDN=IUN
      IF(IUN.NE.0)FILOUT=FILNAM
C
C ADD IN TITLE INFORMATION IF REQUIRED
C -----------------------------------
C
100   IF(NT.LE.0)GO TO 200
C
C REPLACE TITLE
      IF(IADD.LT.0) LTITN=0
C
C FIND THE NUMBER OF THE LAST SIGNIFICANT CHARACTER
C
      DO 110 I=1,NT
      NCH=NT-I+1
      IF(ITITLE(NCH).NE.ISP)GO TO 120
110   CONTINUE
C
C ADD TITLE INFORMATION TO 'ARRAY'
C
120   IF(IADD.LT.2)GO TO 125
      J=LABELN+LTITN+1
      IF(J.GT.MAXDN)GO TO 140
      LTITN=LTITN+1
      ARRAYN(J)=' '
125   DO 130 I=1,NCH
      J=LABELN+LTITN+1
      IF(J.GT.MAXDN)GO TO 140
      LTITN=LTITN+1
      ARRAYN(J)=ITITLE(I)
130   CONTINUE
      GO TO 200
C
C INSUFFICIENT SPACE FOR ALL TITLE INFORMATION
C
140   N=NCH-I+1
      WRITE(IOUT,2001)
      WRITE(IOUT,2002)N
C
C ADD IN LABEL INFORMATION IF REQUIRED
C -----------------------------------
C
200   IF(NL.EQ.0)GO TO 400
C
C FIND THE NUMBER OF CHARACTERS OF LABEL INFORMATION TO BE ADDED
C (AFTER COMPRESSION)
C
      NOSPAC=0
      IF(LABELN.EQ.0.OR.IADD.LT.0)NOSPAC=1
      IF(LABELN.NE.0.AND.ARRAYN(LABELN).EQ.ISP)NOSPAC=1
      NCH=0
      I=0
210   CALL LCFINC(I,LABEL,NL,*220,*210,*250)
220   NCH=NCH+2
230   CALL LCFINC(I,LABEL,NL,*240,*210,*250)
240   NCH=NCH+1
      GO TO 230
C
C CHECK THAT THERE IS SUFFICIENT SPACE FOR THE LABEL INFORMATION
C
250   IF(NOSPAC.EQ.1)NCH=NCH-1
      IF(NCH+LABELN.LT.MAXDN)GO TO 260
      WRITE(IOUT,2000)
      WRITE(IOUT,2003)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 2010')
260   N=NCH+LABELN+LTITN-MAXDN
      IF(N.LE.0)GO TO 270
      WRITE(IOUT,2001)
      WRITE(IOUT,2002)N
      LTITN=LTITN-N
C
C SHIFT TITLE INFORMATION AND COPY LABEL INFORMATION INTO 'ARRAYN'
C
270   M1=LABELN+1
      M2=LABELN+LTITN
      IF(IADD.GE.0) GO TO 271
C REPLACE LABELS IF IADD .LT. 0
C NUMBER OF CHARACTERS TO MOVE TITLE
      NCH=NCH-LABELN
      LABELN=0
271   CALL LCFSHF(ARRAYN,M1,M2,NCH)
C
C COPY LABEL INFORMATION REMOVING REDUNDANT SPACES
C
      I=0
280   CALL LCFINC(I,LABEL,NL,*290,*280,*400)
290   IF(NOSPAC.EQ.1)GO TO 295
      LABELN=LABELN+1
      ARRAYN(LABELN)=ISP
295   LABELN=LABELN+1
      NOSPAC=0
      ARRAYN(LABELN)=LABEL(I)
300   CALL LCFINC(I,LABEL,NL,*310,*280,*400)
310   LABELN=LABELN+1
      ARRAYN(LABELN)=LABEL(I)
      GO TO 300
C
C REPLACE CELL DIMENSIONS IF REQUIRED
C ----------------------------------
C
400   IF(CELL(1).EQ.0.0)GO TO 450
      DO 410 I=1,6
      CELLN(I)=CELL(I)
410   CONTINUE
450   CALL LCFITM(ARRAYN,LABELN,NLABL)
      LRECLN=2*NLABL
C
C WRITE HEADER RECORDS IF REQUIRED
C
      IF(IWRITE.NE.1)RETURN
      CALL WHLCF1(IDATA)
C PRINT HEADER INFORMATION
C
      WRITE(IOUT,1001)IUNOUT,NLABL
      WRITE(IOUT,1002)
      CALL LCFPRT(IOUT,ARRAYN,1,LABELN,1,80)
      WRITE(IOUT,1003)
      CALL LCFPRT(IOUT,ARRAYN,LABELN+1,LABELN+LTITN,1,80)
      WRITE(IOUT,1004)CELLN
      RETURN
C
C FORMAT STATEMENTS
C ----------------
C
1001  FORMAT(//,' HEADER INFORMATION FOR OUTPUT LCF FILE ON UNIT',
     *I3,//,' NUMBER OF COLUMNS =',I4)
1002  FORMAT(/,' * COLUMN LABELS:',/)
1003  FORMAT(/,' * TITLE:',/)
1004  FORMAT(/,' * CELL DIMENSIONS:',//,' ',6F8.2)
C
2000  FORMAT(/,' **LCF ERROR**')
2001  FORMAT(/,' *LCF WARNING*')
2002  FORMAT(' **LAST',I3,' CHARACTERS OF TITLE TRUNCATED**')
2003  FORMAT(' **LABEL INFORMATION TOO LONG**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C-- F77LCF      PCZ.F77LCF2.FORT                                28/02/85    JWC
CZ    Some statements DATA & SAVE exchanged in order            Z110289
C
C SUBROUTINE 'HDLCF2'
C ===================
C
C THE SUBROUTINE 'HDLCF2' IS USED TO SET UP FILE HEADER INFORMATION
C OR ADD FILE HEADER INFORMATION TO THAT ALREADY PRESENT AND,
C OPTIONALLY, TO WRITE THE HEADER RECORDS TO THE OUTPUT FILE VIA THE
C SUBROUTINE 'WHLCF2'
C
      SUBROUTINE HDLCF2(IUN,FILNAM,NT,ITITLE,NL,LABEL,CELL,IADD,IWRITE)
C
C PARAMETERS
C
C           IUN  (I)  UNIT NUMBER FOR OUTPUT FILE (0 TO LEAVE
C                     UNCHANGED)
C        FILNAM  (I)  LOGICAL FILE NAME (UP TO 8 CHARACTERS)
C                     (UNCHANGED IF IUN=0)
C            NT  (I)  THE NUMBER OF CHARACTERS OF TITLE INFORMATION TO
C                     BE ADDED (MAY BE 0)
C        ITITLE  (I)  CHARACTER ARRAY CONTAINING THE TITLE INFORMATION.
C                     THE SUBROUTINE WILL AUTOMATICALLY EXCLUDE
C                     TRAILING SPACES FROM THE TITLE INFORMATION
C                     ADDED.  THE USER SHOULD INSERT LEADING SPACES ETC.
C                     IF REQUIRED, TO SEPARATE ADDITIONAL TITLE
C                     INFORMATION FROM THE TITLE INFORMATION ALREADY
C                     PRESENT (UNLESS IADD=2).
C            NL  (I)  THE NUMBER OF CHARACTERS OF LABEL INFORMATION TO
C                     BE ADDED (MAY BE 0)
C         LABEL  (I)  CHARACTER ARRAY CONTAINING THE LABEL INFORMATION
C                     TO BE ADDED TO THE HEADER INFORMATION.
C                      THE SUBROUTINE WILL AUTOMATICALLY EXCLUDE
C                      REDUNDANT SPACES AND WILL SEPARATE THE NEW
C                     NEW LABELS FROM ANY EXISTING LABELS BY A SPACE.
C          CELL  (I)  THIS IS A SIX ELEMENT REAL ARRAY TO CONTAIN THE
C                     CELL DIMENSIONS FOR THE FILE HEADER.  THE CELL
C                     DIMENSIONS ARE INPUT AS A,B,C,ALPHA,BETA AND GAMMA
C                     IN ANGSTROMS AND DEGREES. IF CELL(1)=0.0, THEN
C                     THE EXISTING CELL DIMENSIONS SET UP IN THE
C                     HEADER WILL REMAIN UNCHANGED
C          IADD  (I)  FLAG =0, INITIALISE THE HEADER INFORMATION AND
C                              THEN ADD IN REQUIRED INFORMATION AS
C                              DEFINED BY THE PARAMETERS ABOVE.
C                          =1, ADD IN HEADER INFORMATION, AS DEFINED
C                              IN THE PARAMETERS ABOVE, TO ANY HEADER
C                              INFORMATION ALREADY PRESENT. (NOTE: CELL
C                              DIMENSIONS WILL BE REPLACED RATHER THAN
C                              ADDED)
C                          =2  AS FOR 1 BUT LEADING SPACE INSERTED
C                              BEFORE NEW TITLE INFORMATION
C                          =-1 REPLACE SOME OF TITLE, LABEL, OR CELL
C                              INFORMATION AS SPECIFIED BY NT, NL, AND
C                              CELL, BUT LEAVE OTHER HEADER INFORMATION
C                              UNCHANGED
C       IWRITE  (I)   FLAG =0, DO NOT WRITE THE HEADER INFORMATION TO
C                              THE FILE (USE THIS EXCEPT ON THE LAST
C                              CALL TO HDLCF2)
C                          =1, WRITE THE HEADER INFORMATION TO THE
C                              OUTPUT FILE
C
C SUBROUTINES CALLED 'LCFINC' 'LCFSHF' 'LCFITM' 'WHLCF2'
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD
      CHARACTER*(*) FILNAM
      CHARACTER*1 ARRAYN(1000),ITITLE(*),LABEL(*),ISP
      DIMENSION IDATA(1),CELL(6)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT
      COMMON /LCF2FN/FILIN,FILOUT
      SAVE /LCF2/,/LCF2AR/,/LCF2WK/,/LCF2FN/
      DATA ISP/' '/
C
C INITIALISE COMMON /LCF2WK/ IF REQUIRED
C
      CALL INLCF2(5,6,72)
C
C INITIALISE SOME COMMON AREA ENTRIES IF IADD=0
C
      MAXDN=1000
      IF(IADD.NE.0)GO TO 50
      DO 10 I=1,6
      CELLN(I)=0.0
10    CONTINUE
      DO 20 I=1,1000
      ARRAYN(I)=ISP
20    CONTINUE
      LTITN=0
      LABELN=0
      MAXDN=1000
      LRECLN=0
C
C SET FLAG FOR DDNAME IF SPECIFIED
C
50    IF(IUN.NE.0)IDDN=IUN
      IF(IUN.NE.0)FILOUT=FILNAM
C
C ADD IN TITLE INFORMATION IF REQUIRED
C -----------------------------------
C
100   IF(NT.LE.0)GO TO 200
C
C REPLACE TITLE
      IF(IADD.LT.0) LTITN=0
C
C FIND THE NUMBER OF THE LAST SIGNIFICANT CHARACTER
C
      DO 110 I=1,NT
      NCH=NT-I+1
      IF(ITITLE(NCH).NE.ISP)GO TO 120
110   CONTINUE
C
C ADD TITLE INFORMATION TO 'ARRAY'
C
120   IF(IADD.LT.2)GO TO 125
      J=LABELN+LTITN+1
      IF(J.GT.MAXDN)GO TO 140
      LTITN=LTITN+1
      ARRAYN(J)=' '
125   DO 130 I=1,NCH
      J=LABELN+LTITN+1
      IF(J.GT.MAXDN)GO TO 140
      LTITN=LTITN+1
      ARRAYN(J)=ITITLE(I)
130   CONTINUE
      GO TO 200
C
C INSUFFICIENT SPACE FOR ALL TITLE INFORMATION
C
140   N=NCH-I+1
      WRITE(IOUT,2001)
      WRITE(IOUT,2002)N
C
C ADD IN LABEL INFORMATION IF REQUIRED
C -----------------------------------
C
200   IF(NL.EQ.0)GO TO 400
C
C FIND THE NUMBER OF CHARACTERS OF LABEL INFORMATION TO BE ADDED
C (AFTER COMPRESSION)
C
      NOSPAC=0
      IF(LABELN.EQ.0.OR.IADD.LT.0)NOSPAC=1
      IF(LABELN.NE.0.AND.ARRAYN(LABELN).EQ.ISP)NOSPAC=1
      NCH=0
      I=0
210   CALL LCFINC(I,LABEL,NL,*220,*210,*250)
220   NCH=NCH+2
230   CALL LCFINC(I,LABEL,NL,*240,*210,*250)
240   NCH=NCH+1
      GO TO 230
C
C CHECK THAT THERE IS SUFFICIENT SPACE FOR THE LABEL INFORMATION
C
250   IF(NOSPAC.EQ.1)NCH=NCH-1
      IF(NCH+LABELN.LT.MAXDN)GO TO 260
      WRITE(IOUT,2000)
      WRITE(IOUT,2003)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 2010')
260   N=NCH+LABELN+LTITN-MAXDN
      IF(N.LE.0)GO TO 270
      WRITE(IOUT,2001)
      WRITE(IOUT,2002)N
      LTITN=LTITN-N
C
C SHIFT TITLE INFORMATION AND COPY LABEL INFORMATION INTO 'ARRAYN'
C
270   M1=LABELN+1
      M2=LABELN+LTITN
      IF(IADD.GE.0) GO TO 271
C REPLACE LABELS IF IADD .LT. 0
C NUMBER OF CHARACTERS TO MOVE TITLE
      NCH=NCH-LABELN
      LABELN=0
271   CALL LCFSHF(ARRAYN,M1,M2,NCH)
C
C COPY LABEL INFORMATION REMOVING REDUNDANT SPACES
C
      I=0
280   CALL LCFINC(I,LABEL,NL,*290,*280,*400)
290   IF(NOSPAC.EQ.1)GO TO 295
      LABELN=LABELN+1
      ARRAYN(LABELN)=ISP
295   LABELN=LABELN+1
      NOSPAC=0
      ARRAYN(LABELN)=LABEL(I)
300   CALL LCFINC(I,LABEL,NL,*310,*280,*400)
310   LABELN=LABELN+1
      ARRAYN(LABELN)=LABEL(I)
      GO TO 300
C
C REPLACE CELL DIMENSIONS IF REQUIRED
C ----------------------------------
C
400   IF(CELL(1).EQ.0.0)GO TO 450
      DO 410 I=1,6
      CELLN(I)=CELL(I)
410   CONTINUE
450   CALL LCFITM(ARRAYN,LABELN,NLABL)
      LRECLN=2*NLABL
C
C WRITE HEADER RECORDS IF REQUIRED
C
      IF(IWRITE.NE.1)RETURN
      CALL WHLCF2(IDATA)
C PRINT HEADER INFORMATION
C
      WRITE(IOUT,1001)IUNOUT,NLABL
      WRITE(IOUT,1002)
      CALL LCFPRT(IOUT,ARRAYN,1,LABELN,1,80)
      WRITE(IOUT,1003)
      CALL LCFPRT(IOUT,ARRAYN,LABELN+1,LABELN+LTITN,1,80)
      WRITE(IOUT,1004)CELLN
      RETURN
C
C FORMAT STATEMENTS
C ----------------
C
1001  FORMAT(//,' HEADER INFORMATION FOR OUTPUT LCF FILE ON UNIT',
     *I3,//,' NUMBER OF COLUMNS =',I4)
1002  FORMAT(/,' * COLUMN LABELS:',/)
1003  FORMAT(/,' * TITLE:',/)
1004  FORMAT(/,' * CELL DIMENSIONS:',//,' ',6F8.2)
C
2000  FORMAT(/,' **LCF ERROR**')
2001  FORMAT(/,' *LCF WARNING*')
2002  FORMAT(' **LAST',I3,' CHARACTERS OF TITLE TRUNCATED**')
2003  FORMAT(' **LABEL INFORMATION TOO LONG**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'HRLCF1'
C ===================
C
C THIS SUBROUTINE IS USED TO INPUT THE HEADER RECORDS FROM A STANDARD
C LCF REFLECTION DATA FILE (ORIGINAL DEFINITION)
C
      SUBROUTINE HRLCF1(IERR)
C
C PARAMETERS
C
C       IERR (O)   ERROR FLAG  =0 NO ERROR
C                              =1 ERROR IN BEGINNING OF HEADER RECORD
C                              =2 ERROR IN CELL DIMENSIONS RECORDS
C                              =3 ERROR IN LABELS RECORDS
C                              =4 ERROR IN TITLE RECORDS
C                              =5 ERROR IN END OF HEADER RECORD
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      CHARACTER*1 CH(2)
      LOGICAL RD
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1/,/LCF1AR/,/LCF1WK/
C
C INITIALISATIONS
C
      NUMBS=-32768
      NUMBC=-32767
      NUMBL=-32766
      NUMBT=-32765
      NUMBE=-32764
      IERR=0
      DO 10 I=1,8
      KDATA(I)=0
10    CONTINUE
C
C READ BEGINNING OF HEADER RECORD
C -------------------------------
C
      JERR=1
      CALL RLCF1(KDATA,*810,*810)
      IF(KDATA(1).NE.NUMBS)GO TO 810
      MM=MIN(NCIN-2,6)
      LRECLN=-KDATA(MM+1)
C
C READ CELL PARAMETERS
C --------------------
C
100   JERR=2
      NVAL=(NCIN-MM)/2
      NREC=5/NVAL+1
      K=0
      DO 120 N=1,NREC
      CALL RLCF1(KDATA,*810,*810)
      M=MM-1
      DO 110 I=1,NVAL
      M=M+2
      K=K+1
      IF(K.LE.6)CALL CELCF1(KDATA,M,CELLN(K),1)
110   CONTINUE
120   CONTINUE
C
C READ LABELS INFORMATION
C -----------------------
C
200   JERR=3
      ISEQ=0
      MINC=MM+1
      LL=0
210   CALL RLCF1(KDATA,*810,*810)
      ISEQ=ISEQ+1
      IF(ISEQ.EQ.1.AND.KDATA(1).NE.NUMBL)GO TO 800
      IF(KDATA(1).NE.NUMBL)GO TO 250
      IF(KDATA(MM).NE.ISEQ)GO TO 800
      CALL CHLCF1(KDATA,MINC,NCIN,ARRAYN,1000,LL,1,*210)
      GO TO 210
250   DO 260 L=1,LL
      K=LL-L+1
      IF(ARRAYN(K).NE.' ')GO TO 270
260   CONTINUE
270   LABELN=K
C
C READ TITLE INFORMATION
C ----------------------
C
300   JERR=4
      ISEQ=0
      LL=K
      GO TO 315
310   CALL RLCF1(KDATA,*810,*810)
315   ISEQ=ISEQ+1
      IF(ISEQ.EQ.1.AND.KDATA(1).NE.NUMBT)GO TO 800
      IF(KDATA(1).NE.NUMBT)GO TO 350
      IF(KDATA(MM).NE.ISEQ)GO TO 800
      CALL CHLCF1(KDATA,MINC,NCIN,ARRAYN,1000,LL,1,*310)
      GO TO 310
350   DO 360 L=LABELN+1,LL
      K=LL-L+1
      IF(ARRAYN(K).NE.' ')GO TO 370
360   CONTINUE
370   LTITN=K
C
C CHECK END OF HEADER RECORD
C --------------------------
C
400   JERR=5
      IF(KDATA(1).NE.NUMBE)GO TO 800
      RETURN
C
C ERROR CONDITIONS
C ----------------
C
800   WRITE(IOUT,2001)
810   IERR=JERR
      RETURN
C
C FORMAT STATEMENTS
C -----------------
C
2001  FORMAT(/,' **LCF ERROR**',/,' **HEADER RECORDS OUT OF SEQUENCE**')
      END
C
C SUBROUTINE 'HRLCF2'
C ===================
C
C THIS SUBROUTINE IS USED TO INPUT THE HEADER RECORDS FROM A STANDARD
C LCF REFLECTION DATA FILE (ORIGINAL DEFINITION)
C
      SUBROUTINE HRLCF2(IERR)
C
C PARAMETERS
C
C       IERR (O)   ERROR FLAG  =0 NO ERROR
C                              =1 ERROR IN BEGINNING OF HEADER RECORD
C                              =2 ERROR IN CELL DIMENSIONS RECORDS
C                              =3 ERROR IN LABELS RECORDS
C                              =4 ERROR IN TITLE RECORDS
C                              =5 ERROR IN END OF HEADER RECORD
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      CHARACTER*1 CH(2)
      LOGICAL RD
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2/,/LCF2AR/,/LCF2WK/
C
C INITIALISATIONS
C
      NUMBS=-32768
      NUMBC=-32767
      NUMBL=-32766
      NUMBT=-32765
      NUMBE=-32764
      IERR=0
      DO 10 I=1,8
      KDATA(I)=0
10    CONTINUE
C
C READ BEGINNING OF HEADER RECORD
C -------------------------------
C
      JERR=1
      CALL RLCF2(KDATA,*810,*810)
      IF(KDATA(1).NE.NUMBS)GO TO 810
      MM=MIN(NCIN-2,6)
      LRECLN=-KDATA(MM+1)
C
C READ CELL PARAMETERS
C --------------------
C
100   JERR=2
      NVAL=(NCIN-MM)/2
      NREC=5/NVAL+1
      K=0
      DO 120 N=1,NREC
      CALL RLCF2(KDATA,*810,*810)
      M=MM-1
      DO 110 I=1,NVAL
      M=M+2
      K=K+1
      IF(K.LE.6)CALL CELCF2(KDATA,M,CELLN(K),1)
110   CONTINUE
120   CONTINUE
C
C READ LABELS INFORMATION
C -----------------------
C
200   JERR=3
      ISEQ=0
      MINC=MM+1
      LL=0
210   CALL RLCF2(KDATA,*810,*810)
      ISEQ=ISEQ+1
      IF(ISEQ.EQ.1.AND.KDATA(1).NE.NUMBL)GO TO 800
      IF(KDATA(1).NE.NUMBL)GO TO 250
      IF(KDATA(MM).NE.ISEQ)GO TO 800
      CALL CHLCF2(KDATA,MINC,NCIN,ARRAYN,1000,LL,1,*210)
      GO TO 210
250   DO 260 L=1,LL
      K=LL-L+1
      IF(ARRAYN(K).NE.' ')GO TO 270
260   CONTINUE
270   LABELN=K
C
C READ TITLE INFORMATION
C ----------------------
C
300   JERR=4
      ISEQ=0
      LL=K
      GO TO 315
310   CALL RLCF2(KDATA,*810,*810)
315   ISEQ=ISEQ+1
      IF(ISEQ.EQ.1.AND.KDATA(1).NE.NUMBT)GO TO 800
      IF(KDATA(1).NE.NUMBT)GO TO 350
      IF(KDATA(MM).NE.ISEQ)GO TO 800
      CALL CHLCF2(KDATA,MINC,NCIN,ARRAYN,1000,LL,1,*310)
      GO TO 310
350   DO 360 L=LABELN+1,LL
      K=LL-L+1
      IF(ARRAYN(K).NE.' ')GO TO 370
360   CONTINUE
370   LTITN=K
C
C CHECK END OF HEADER RECORD
C --------------------------
C
400   JERR=5
      IF(KDATA(1).NE.NUMBE)GO TO 800
      RETURN
C
C ERROR CONDITIONS
C ----------------
C
800   WRITE(IOUT,2001)
810   IERR=JERR
      RETURN
C
C FORMAT STATEMENTS
C -----------------
C
2001  FORMAT(/,' **LCF ERROR**',/,' **HEADER RECORDS OUT OF SEQUENCE**')
      END
C-- F77LCF      PCZ.F77LCF1A.FORT                                6/04/84    JWC
C
C SUBROUTINE 'HWLCF1'
C ===================
C
C THIS SUBROUTINE IS USED TO WRITE THE HEADER RECORDS TO A STANDARD
C LCF REFLECTION DATA FILE (ORIGINAL DEFINITION)
C
      SUBROUTINE HWLCF1
C
C PARAMETERS NONE
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      CHARACTER*1 CH(2)
      LOGICAL RD
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1/,/LCF1AR/,/LCF1WK/
      CALL BADLCF
C
C INITIALISATIONS
C
      NUMBS=-32768
      NUMBC=-32767
      NUMBL=-32766
      NUMBT=-32765
      NUMBE=-32764
      MM=MIN(NCOUT-2,6)
      LRECLN=2*NCOUT
C
C WRITE BEGINNING OF HEADER RECORD
C --------------------------------
C
100   DO 110 N=1,NCOUT
      KDATA(N)=NUMBS
110   CONTINUE
      KDATA(MM+1)=-LRECLN
      KDATA(MM+2)=LABELN+LTITN
      CALL WLCF1(KDATA)
C
C OUTPUT CELL DIMENSIONS RECORDS
C ------------------------------
C
      NVAL=(NCOUT-MM)/2
      NREC=5/NVAL+1
      DO 210 N=1,NCOUT
      KDATA(N)=NUMBC
210   CONTINUE
      K=0
      ISEQ=0
      DO 230 N=1,NREC
      M=MM-1
      DO 220 I=1,NVAL
      M=M+2
      K=K+1
      IF(K.LE.6)CALL CELCF1(KDATA,M,CELLN(K),2)
220   CONTINUE
      ISEQ=ISEQ+1
      KDATA(MM)=ISEQ
      CALL WLCF1(KDATA)
230   CONTINUE
C
C OUTPUT LABELS RECORDS
C ---------------------
C
300   DO 310 M=1,MM-1
      KDATA(M)=NUMBL
310   CONTINUE
      L=0
      ISEQ=0
320   ISEQ=ISEQ+1
      KDATA(MM)=ISEQ
      CALL CHLCF1(KDATA,MM+1,NCOUT,ARRAYN,LABELN,L,2,*400)
      CALL WLCF1(KDATA)
      GO TO 320
C
C OUTPUT TITLE RECORDS
C --------------------
C
400   DO 410 M=1,MM-1
      KDATA(M)=NUMBT
410   CONTINUE
      L=LABELN
      ISEQ=0
420   ISEQ=ISEQ+1
      KDATA(MM)=ISEQ
      CALL CHLCF1(KDATA,MM+1,NCOUT,ARRAYN,LABELN+LTITN,L,2,*500)
      CALL WLCF1(KDATA)
      GO TO 420
C
C OUTPUT END OF HEADER RECORD
C ---------------------------
C
500   DO 510 N=1,NCOUT
      KDATA(N)=NUMBE
510   CONTINUE
      CALL WLCF1(KDATA)
      RETURN
      END
C-- F77LCF      PCZ.F77LCF2A.FORT                                6/04/84
C
C SUBROUTINE 'HWLCF2'
C ===================
C
C THIS SUBROUTINE IS USED TO WRITE THE HEADER RECORDS TO A STANDARD
C LCF REFLECTION DATA FILE (ORIGINAL DEFINITION)
C
      SUBROUTINE HWLCF2
C
C PARAMETERS NONE
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      CHARACTER*1 CH(2)
      LOGICAL RD
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2/,/LCF2AR/,/LCF2WK/
      CALL BADLCF
C
C INITIALISATIONS
C
      NUMBS=-32768
      NUMBC=-32767
      NUMBL=-32766
      NUMBT=-32765
      NUMBE=-32764
      MM=MIN(NCOUT-2,6)
      LRECLN=2*NCOUT
C
C WRITE BEGINNING OF HEADER RECORD
C --------------------------------
C
100   DO 110 N=1,NCOUT
      KDATA(N)=NUMBS
110   CONTINUE
      KDATA(MM+1)=-LRECLN
      KDATA(MM+2)=LABELN+LTITN
      CALL WLCF2(KDATA)
C
C OUTPUT CELL DIMENSIONS RECORDS
C ------------------------------
C
      NVAL=(NCOUT-MM)/2
      NREC=5/NVAL+1
      DO 210 N=1,NCOUT
      KDATA(N)=NUMBC
210   CONTINUE
      K=0
      ISEQ=0
      DO 230 N=1,NREC
      M=MM-1
      DO 220 I=1,NVAL
      M=M+2
      K=K+1
      IF(K.LE.6)CALL CELCF2(KDATA,M,CELLN(K),2)
220   CONTINUE
      ISEQ=ISEQ+1
      KDATA(MM)=ISEQ
      CALL WLCF2(KDATA)
230   CONTINUE
C
C OUTPUT LABELS RECORDS
C ---------------------
C
300   DO 310 M=1,MM-1
      KDATA(M)=NUMBL
310   CONTINUE
      L=0
      ISEQ=0
320   ISEQ=ISEQ+1
      KDATA(MM)=ISEQ
      CALL CHLCF2(KDATA,MM+1,NCOUT,ARRAYN,LABELN,L,2,*400)
      CALL WLCF2(KDATA)
      GO TO 320
C
C OUTPUT TITLE RECORDS
C --------------------
C
400   DO 410 M=1,MM-1
      KDATA(M)=NUMBT
410   CONTINUE
      L=LABELN
      ISEQ=0
420   ISEQ=ISEQ+1
      KDATA(MM)=ISEQ
      CALL CHLCF2(KDATA,MM+1,NCOUT,ARRAYN,LABELN+LTITN,L,2,*500)
      CALL WLCF2(KDATA)
      GO TO 420
C
C OUTPUT END OF HEADER RECORD
C ---------------------------
C
500   DO 510 N=1,NCOUT
      KDATA(N)=NUMBE
510   CONTINUE
      CALL WLCF2(KDATA)
      RETURN
      END
C
C SUBROUTINE 'INLCF1'
C ====================
C
C SUBROUTINE TO INITIALISE THE COMMON BLOCK /LCF1WK/ ON THE FIRST
C CALL MADE TO IT.
C
      SUBROUTINE INLCF1(JN,JOUT,JBUF)
C
C PARAMETERS
C
C          JN (I)   UNIT NO. FOR READING LCF ASSIGNMENTS.
C        JOUT (I)   UNIT NO. FOR PRINTING TITLE, LABELS MESSAGES ETC.
C        JBUF (I)   NO. OF COLUMNS TO BE READ FOR LCF ASSIGNMENTS.
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      LOGICAL RD,INIT
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1WK/,INIT
      DATA INIT/.FALSE./
C
C RETURN IF NOT THE FIRST CALL TO THE SUBROUTINE
C ----------------------------------------------
C
      IF(INIT)RETURN
C
C PERFORM INITIALISATIONS AND SET INITIALISATION FLAG
C ---------------------------------------------------
C
      INIT=.TRUE.
      IN=JN
      IOUT=JOUT
      LBUF=JBUF
      RD=.FALSE.
      IUNIN=0
      NCIN=0
      IUNOUT=0
      NCOUT=0
      NLOOK=0
      DO 10 I=1,100
      IPOINT(I)=0
10    CONTINUE
      RETURN
      END
C
C SUBROUTINE 'INLCF2'
C ====================
C
C SUBROUTINE TO INITIALISE THE COMMON BLOCK /LCF2WK/ ON THE FIRST
C CALL MADE TO IT.
C
      SUBROUTINE INLCF2(JN,JOUT,JBUF)
C
C PARAMETERS
C
C          JN (I)   UNIT NO. FOR READING LCF ASSIGNMENTS.
C        JOUT (I)   UNIT NO. FOR PRINTING TITLE, LABELS MESSAGES ETC.
C        JBUF (I)   NO. OF COLUMNS TO BE READ FOR LCF ASSIGNMENTS.
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      LOGICAL RD,INIT
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2WK/,INIT
      DATA INIT/.FALSE./
C
C RETURN IF NOT THE FIRST CALL TO THE SUBROUTINE
C ----------------------------------------------
C
      IF(INIT)RETURN
C
C PERFORM INITIALISATIONS AND SET INITIALISATION FLAG
C ---------------------------------------------------
C
      INIT=.TRUE.
      IN=JN
      IOUT=JOUT
      LBUF=JBUF
      RD=.FALSE.
      IUNIN=0
      NCIN=0
      IUNOUT=0
      NCOUT=0
      NLOOK=0
      DO 10 I=1,100
      IPOINT(I)=0
10    CONTINUE
      RETURN
      END
C
C
C SUBROUTINE 'LCF1OR'
C ====================
C
C THIS SUBROUTINE OPENS AN LCF FILE FOR READING
C
      SUBROUTINE LCF1OR(*)
C
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT,FILNAM,FILOLD
      COMMON /LCF1FN/FILIN,FILOUT
      INTEGER ISTATB(12)
      SAVE ISTREAM,FILOLD,NFILSZ
      SAVE /LCF1/,/LCF1AR/,/LCF1WK/,/LCF1FN/
C ISTREAM is used to record if file has been opened
      DATA ISTREAM/0/
C
C If file has been opened, has not been closed, and has same filename,
C then just reposition file at beginning
      IF(ISTREAM.NE.0.AND.IUNIN.GT.0.AND.FILOLD.EQ.FILIN) THEN
            CALL QSEEK(IUNIN,1,1,1)
            RETURN
      ENDIF
C
      CALL QOPEN(IUNIN,FILIN,'RO')
C
C Record file as open
      ISTREAM=IUNIN
      FILOLD=FILIN
C Set mode 1 = 2 bytes/item, so that subsequent counting is done in 2 by
C integers
      CALL QMODE(IUNIN,1,NCHITM)
CZ I removed this function. Be carefull in SORTLCF and EDITLCF
C      I=STAT(FILNAM,ISTATB)
      ISTATB(8)=0
      NFILSZ=(ISTATB(8)-1)/1024 + 1
C
50    NCIN=6
      CALL RLCF1(KDATA,*800,*800)
      IF(KDATA(1).NE.-32768)GO TO 810
      IF(KDATA(5).EQ.-12)GO TO 100
C Rewind
      CALL QSEEK(IUNIN,1,1,1)
      NCIN=7
      CALL RLCF1(KDATA,*800,*800)
      IF(KDATA(6).EQ.-14)GO TO 100
      NCIN=-KDATA(7)/2
      IF(NCIN.LT.0.OR.NCIN.GT.100)GO TO 810
C Rewind
100   CALL QSEEK(IUNIN,1,1,1)
      RETURN
C
C ERROR CONDITIONS
C
800   RETURN 1
810   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      RETURN 1
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(' **ERROR IN BEGINNING OF HEADER RECORD**')
C
C
C ENTRY 'LRLCF1'
C ==============
C
C This entry returns the record length in items
C
      ENTRY LRLCF1(LRCL)
C
      LRCL=NCIN
      RETURN
C
C ENTRY 'SZLCF1'
C ==============
C
C This entry returns the size of the file in blocks
C
      ENTRY SZLCF1(NSZ)
C
      NSZ=NFILSZ
      RETURN
C
      END
CZ Version for HP                                                  Z110289
CZ     Sequence of statements SAVE & DATA was changed in some routines
CZ   Function SZLCF2 returns a dummy 0 argument. (It is used
CZ      in SORTLCF & EDITLCF only)
CZ     Developed from:
C Version for Convex using DISKIO routines QOPEN,QMODE,QREAD,
C    QWRITE,QCLOSE
C
C Extra entry points  SWLCF1, LRLCF1, SZLCF1
C
C Convex version, John Campbell August 1988
C
C  Correction to CWLCF1  Sep 1985 PRE
C
C
C SUBROUTINE 'LCF1OW'
C ====================
C
C THIS SUBROUTINE OPENS AN LCF FILE FOR WRITE
C
      SUBROUTINE LCF1OW(*)
C
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT,FILNAM
      COMMON /LCF1FN/FILIN,FILOUT
      CHARACTER NSTAT*(*)
      INTEGER ISTATB(12),STAT
      SAVE /LCF1/,/LCF1AR/,/LCF1WK/,/LCF1FN/,ISTAT,NFILSZ
      DATA ISTAT/4/
      CALL BADLCF
C
C Open file with specified status, default NEW
      CALL QQOPEN(IUNOUT,FILOUT,ISTAT)
C Set mode 1 = 2bytes / item, so that all subsequent counting is in 2-by
C integers
      CALL QMODE(IUNOUT,1,NCHITM)
CZ I removed this function. Be carefull in SORTLCF and EDITLCF
C      I=STAT(FILNAM,ISTATB)
      ISTATB(8)=0
      NFILSZ=(ISTATB(8)-1)/1024 + 1
      RETURN
C
C
C ENTRY 'SWLCF1'
C ==============
C
C This entry changes the open status for subsequent calls to LCF1OW
C NSTAT = 'NEW' (default), 'OLD', 'SCRATCH' or 'UNKNOWN'
C
      ENTRY SWLCF1(NSTAT)
C
      IF(NSTAT.EQ.'NEW'.OR.NSTAT.EQ.'OLD'.OR.NSTAT.EQ.'UNKNOWN'
     .       .OR.NSTAT.EQ.'SCRATCH') THEN
        IF(NSTAT.EQ.'NEW')ISTAT=4
        IF(NSTAT.EQ.'OLD')ISTAT=3
        IF(NSTAT.EQ.'UNKNOWN')ISTAT=1
        IF(NSTAT.EQ.'SCRATCH')ISTAT=2
      ELSE
            WRITE(*,1001) NSTAT
1001      FORMAT(' **LCF ERROR** Illegal status in SWLCF1: ',A)
          call ccperr(1,' stop in lcflib.for 1001')
      ENDIF
      RETURN
C
      END
C
C
C SUBROUTINE 'LCF2OR'
C ====================
C
C THIS SUBROUTINE OPENS AN LCF FILE FOR READING
C
      SUBROUTINE LCF2OR(*)
C
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT,FILNAM,FILOLD
      COMMON /LCF2FN/FILIN,FILOUT
      INTEGER ISTATB(12)
C ISTREAM is used to record if file has been opened
      SAVE ISTREAM,FILOLD,NFILSZ
      SAVE /LCF2/,/LCF2AR/,/LCF2WK/,/LCF2FN/
      DATA ISTREAM/0/
C
C If file has been opened, has not been closed, and has same filename,
C then just reposition file at beginning
      IF(ISTREAM.NE.0.AND.IUNIN.GT.0.AND.FILOLD.EQ.FILIN) THEN
            CALL QSEEK(IUNIN,1,1,1)
            RETURN
      ENDIF
C
      CALL QOPEN(IUNIN,FILIN,'RO')
C
C Record file as open
      ISTREAM=IUNIN
      FILOLD=FILIN
C Set mode 1 = 2 bytes/item, so that subsequent counting is done in 2 by
C integers
      CALL QMODE(IUNIN,1,NCHITM)
CZ I removed this function. Be carefull in SORTLCF and EDITLCF
C      I=STAT(FILNAM,ISTATB)
      ISTATB(8)=0
      NFILSZ=(ISTATB(8)-1)/1024 + 1
C
50    NCIN=6
      CALL RLCF2(KDATA,*800,*800)
      IF(KDATA(1).NE.-32768)GO TO 810
      IF(KDATA(5).EQ.-12)GO TO 100
C Rewind
      CALL QSEEK(IUNIN,1,1,1)
      NCIN=7
      CALL RLCF2(KDATA,*800,*800)
      IF(KDATA(6).EQ.-14)GO TO 100
      NCIN=-KDATA(7)/2
      IF(NCIN.LT.0.OR.NCIN.GT.100)GO TO 810
C Rewind
100   CALL QSEEK(IUNIN,1,1,1)
      RETURN
C
C ERROR CONDITIONS
C
800   RETURN 1
810   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      RETURN 1
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(' **ERROR IN BEGINNING OF HEADER RECORD**')
C
C
C ENTRY 'LRLCF2'
C ==============
C
C This entry returns the record length in items
C
      ENTRY LRLCF2(LRCL)
C
      LRCL=NCIN
      RETURN
C
C ENTRY 'SZLCF2'
C ==============
C
C This entry returns the size of the file in blocks
C
      ENTRY SZLCF2(NSZ)
C
      NSZ=NFILSZ
      RETURN
C
      END
CZ Version for HP                                            Z110289
CZ   Some SAVE & DATA statements were reordered.
CZ   Function SZLCF2 returns a dummy 0 argument. (It is used
CZ      in SORTLCF & EDITLCF only)
CZ   Developed from:
C
C Version for Convex using DISKIO routines QOPEN,QMODE,QREAD,
C    QWRITE,QCLOSE
C
C EXTRA ENTRY POINTS  SWLCF2, LRLCF2, SZLCF2
C
C Convex versuion, John Campbell August 1988
C Correction to CWLCF2 Sep 1985  PRE
C
C
C SUBROUTINE 'LCF2OW'
C ====================
C
C THIS SUBROUTINE OPENS AN LCF FILE FOR WRITE
C
      SUBROUTINE LCF2OW(*)
C
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT,FILNAM
      COMMON /LCF2FN/FILIN,FILOUT
      CHARACTER NSTAT*(*)
      INTEGER ISTATB(12),STAT
      SAVE /LCF2/,/LCF2AR/,/LCF2WK/,/LCF2FN/,ISTAT,NFILSZ
      DATA ISTAT/4/
      CALL BADLCF
C
C Open file with specified status, default NEW
      CALL QQOPEN(IUNOUT,FILOUT,ISTAT)
C Set mode 1 = 2bytes / item, so that all subsequent counting is in 2-by
C integers
      CALL QMODE(IUNOUT,1,NCHITM)
CZ I removed this function. Be carefull in SORTLCF and EDITLCF
C      I=STAT(FILNAM,ISTATB)
      ISTATB(8)=0
      NFILSZ=(ISTATB(8)-1)/1024 + 1
      RETURN
C
C
C ENTRY 'SWLCF2'
C ==============
C
C THIS ENTRY CHANGES THE OPEN STATUS FOR SUBSEQUENT CALLS TO LCF2OW
C NSTAT = 'NEW' (default), 'OLD', 'SCRATCH' or 'UNKNOWN'
C
      ENTRY SWLCF2(NSTAT)
C
      IF(NSTAT.EQ.'NEW'.OR.NSTAT.EQ.'OLD'.OR.NSTAT.EQ.'UNKNOWN'
     .      .OR.NSTAT.EQ.'SCRATCH') THEN
        IF(NSTAT.EQ.'NEW')ISTAT=4
        IF(NSTAT.EQ.'OLD')ISTAT=3
        IF(NSTAT.EQ.'UNKNOWN')ISTAT=1
        IF(NSTAT.EQ.'SCRATCH')ISTAT=2
      ELSE
            WRITE(*,1001) NSTAT
1001      FORMAT(' **LCF ERROR** Illegal status in SWLCF2: ',A)
          call ccperr(1,' stop in lcflib.for 1001')
      ENDIF
      RETURN
C
      END
C
C
      SUBROUTINE LCFASG(I,BUF,LBUF,IP1,IP2,IL1,IL2,*,*,*)
C     ===================================================
C
C This subroutine finds the min and max character numbers for
C the program label and column label from an lcf assignment
C
C
C---- Parameters
C
C           I (I)   ASSIGNMENT NUMBER
C         BUF (I)   CHARACTER ARRAY HOLDING ASSIGNMENTS
C        LBUF (I)   NUMBER OF CHARACTERS IN 'BUF'
C         IP1 (O)   FIRST CHARACTER OF PROGRAM LABEL
C         IP2 (O)   FINAL CHARACTER OF PROGRAM LABEL
C         IL1 (O)   FIRST CHARACTER OF COLUMN LABEL
C         IL2 (O)   FINAL CHARACTER OF COLUMN LABEL
C
C   RETURN 1   BLANK FOUND
C   RETURN 2   TERMINATOR FOUND $$ OR ##
C   RETURN 3   SYNTAX ERROR IN ASSIGNMENT
C
C
C---- Specification statements
C
      CHARACTER*1 BUF(LBUF)
C
C---- Decode assignment
C
      CALL LCFLBL(I,BUF,LBUF,MIN,MAX,*100)
      IF(MAX-MIN.NE.1)GO TO 20
      IF(BUF(MIN).EQ.'$'.AND.BUF(MAX).EQ.'$')RETURN 2
      IF(BUF(MIN).EQ.'#'.AND.BUF(MAX).EQ.'#')RETURN 2
      RETURN 3
20    IP1=MIN
      IL2=MAX
      K=MIN
30    IP2=K
      K=K+1
      IF(K.GT.MAX)RETURN 3
      IF(BUF(K).NE.'=')GO TO 30
      IL1=K+1
      IF(IL1.GT.IL2)RETURN 3
      RETURN
100   RETURN 1
      END
C
C
      FUNCTION LCFCMP(ARRAY1,MIN1,MAX1,ARRAY2,MIN2,MAX2)
C     ==================================================
C
C This function compares two character strings for a match
C
C
C---- Parameters
C
C      ARRAY1 (I)   CHARACTER ARRAY CONTAINING FIRST CHARACTER STRING
C        MIN1 (I)   FIRST CHARACTER OF STRING IN ARRAY1
C        MAX1 (I)   FINAL CHARACTER OF STRING IN ARRAY1
C      ARRAY2 (I)   CHARACTER ARRAY CONTAINING SECOND STRING
C        MIN2 (I)   FIRST CHARACTER OF STRING IN ARRAY2
C        MAX2 (I)   FINAL CHARACTER OF STRING IN ARRAY2
C
C  LCFCMP RETURNS 0=NO MATCH, 1=MATCH
C
C---- Specification statements
C
      CHARACTER*1 ARRAY1(MAX1),ARRAY2(MAX2)
C
C---- Compare strings
C
      LCFCMP=0
      IF(MAX2-MIN2.NE.MAX1-MIN1)RETURN
      IF(MAX1-MIN1.LT.0)RETURN
      J=MIN2-1
      DO 100 M=MIN1,MAX1
      J=J+1
      IF(ARRAY1(M).NE.ARRAY2(J))RETURN
100   CONTINUE
      LCFCMP=1
      RETURN
      END
C
C
      SUBROUTINE LCFINC(N,IARRAY,NMAX,*,*,*)
C     ======================================
C
C This subroutine is used to increment a character position count and
C to determine whether the next character is a space or whether it is
C passed the end of the input character string
C
C
C---- Parameters
C
C           N (I/O) CHARACTER POSITION NUMBER IN THE CHARACTER
C                   STRING
C      IARRAY (I)   ARRAY CONTAINING CHARACTER STRING
C        NMAX (I)   MAXIMUM NUMBER OF CHARACTERS IN CHARACTER
C                   STRING HELD IN 'IARRAY'
C      RETURN 1     CHARACTER IS NOT A SPACE
C      RETURN 2     CHARACTER IS A SPACE
C      RETURN 3     END OF CHARACTER STRING PASSED (OVERRIDES RETURNS
C                   1 AND 2 IF THIS CONDITION IS FOUND)
C
C
C
C---- Specification statements and code
C
      CHARACTER*1 IARRAY(*)
      N=N+1
      IF(N.GT.NMAX)RETURN 3
      IF(IARRAY(N).EQ.' ')RETURN 2
      RETURN 1
      END
C
C
      SUBROUTINE LCFITM(LABEL,NL,NLABL)
C     =================================
C
C This subroutine returns the number of labels in a packed
C labels string
C
C
C---- Parameters
C
C       LABEL (I) ARRAY CONTAINING THE LABEL INFORMATION IN
C                 A CHARACTER STRING
C          NL (I) THE NUMBER OF CHARACTERS IN THE ARRAY 'LABEL'
C       NLABL (O) THE NUMBER OF LABELS
C
C SUBROUTINES CALLED 'LCFLBL'
C
C
C---- Specification statements and code
C
      CHARACTER*1 LABEL(*)
      N=0
10    NLABL=N
      N=N+1
      CALL LCFLBL(N,LABEL,NL,M1,M2,*20)
      GO TO 10
20    RETURN
      END
C
C
      SUBROUTINE LCFLBL(N,ARRAYN,LABELN,MIN,MAX,*)
C     ============================================
C
C This subroutine finds the minimum and maximum character numbers
C in a string of labels for a given label number.
C
C
C---- Parameters
C
C                 N (I) NUMBER OF THE LABEL TO BE FOUND
C            ARRAYN (I) CHARACTER ARRAY CONTAINING THE LABELS
C            LABELN (I) NUMBER OF CHARACTERS IN 'ARRAYN'
C               MIN (O) THE NUMBER OF THE FIRST CHARACTER IN THE LABEL
C                       (OR -1 IF ABSENT OR BLANK FIELD)
C               MAX (O) THE NUMBER OF THE LAST CHARACTER IN THE LABEL
C             *         RETURN IF A BLANK FIELD IS FOUND
C
C---- Specification statements
C
      CHARACTER*1 ARRAYN(*),IBL
      DATA IBL/' '/
C
C---- Initialisation statements
C
      IFIELD=0
      I=0
      MIN=-1
      MAX=LABELN
C
C---- Skip spaces up to next occupied field
C
10    I=I+1
      IF(I.GT.LABELN)RETURN 1
      IF(ARRAYN(I).EQ.IBL)GO TO 10
C
C---- An occupied field has been found, calculate the field number
C     and compare it with the one required
C
20    IFIELD=IFIELD+1
      IF(IFIELD.GT.N)RETURN 1
      IF(IFIELD.EQ.N)GO TO 100
C
C---- Required field not yet reached   skip over current field
C
25    I=I+1
      IF(I.GT.LABELN)RETURN 1
      IF(ARRAYN(I).EQ.IBL)GO TO 10
      GO TO 25
C
C---- Required field found   find the end of the field
C
100   MIN=I
110   I=I+1
      IF(I.GT.LABELN)RETURN
      IF(ARRAYN(I).EQ.IBL)GO TO 120
      GO TO 110
120   MAX=I-1
      RETURN
      END
C
C
      SUBROUTINE LCFPRT(IOUT,ARRAY,MIN,MAX,MINCOL,MAXCOL)
C     ===================================================
C
C  This subroutine prints a set of labels in a given field width
C  without splitting labels unless they exceed the field width
C
C
C---- Parameters
C
C        IOUT (I)   UNIT NUMBER FOR PRINTING THE LABELS
C       ARRAY (I)   CHARACTER ARRAY CONTAINING LABELS
C         MIN (I)   START OF LABELS STRING IN 'ARRAY'
C         MAX (I)   FINISH OF LABELS STRING IN 'ARRAY'
C      MINCOL (I)   FIRST COLUMN OF PRINT FIELD
C      MAXCOL (I)   FINAL COLUMN OF PRINT FIELD
C
C---- Specification statements
C
      CHARACTER*1 ARRAY(MAX),SP
      DATA SP/' '/
C
C---- Print labels
C
      NCH=MAXCOL-MINCOL+1
      ILAST=MIN-1
30    IMIN=ILAST+1
      IF(IMIN.GT.MAX)RETURN
      IF(ARRAY(IMIN).NE.SP)GO TO 35
      ILAST=IMIN
      GO TO 30
35    IMAX=ILAST+NCH
      IF(IMAX.GE.MAX)GO TO 60
      IF(ARRAY(IMAX).EQ.SP)GO TO 70
      IF(ARRAY(IMAX+1).EQ.SP)GO TO 70
40    IMAX=IMAX-1
      IF(IMAX.EQ.IMIN)GO TO 50
      IF(ARRAY(IMAX).EQ.SP)GO TO 70
      GO TO 40
50    IMAX=ILAST+NCH
      IF(IMAX.LT.MAX)GO TO 70
60    IMAX=MAX
70    ILAST=IMAX
      WRITE(IOUT,1000)(SP,M=1,MINCOL),(ARRAY(I),I=IMIN,IMAX)
      GO TO 30
C
C---- Format statements
C
1000  FORMAT(132A1)
      END
C
C
      SUBROUTINE LCFSHF(IARRAY,MIN,MAX,N)
C     ===================================
C
C This subroutine shifts a field of characters within a
C character string 'n' characters to the right or left
C
C
C---- Parameters
C
C      IARRAY (I/O) THE ARRAY CONTAINING A  CHARACTER STRING
C                   FOR WHICH THE CHARACTERS ARE TO BE SHIFTED
C         MIN (I)   THE POSITION OF THE FIRST CHARACTER TO BE SHIFTED
C         MAX (I)   THE POSITION OF THE FINAL CHARACTER TO BE SHIFTED
C           N (I)   THE NUMBER OF PLACES THE CHARACTERS ARE TO BE
C                   SHIFTED TO THE RIGHT; IF N .LT. 0 THE SHIFT IS TO
C                   LEFT
C
C
C---- Specification statements and code
C
      CHARACTER*1 IARRAY(*)
      DO 10 M=MIN,MAX
      I=M
      IF(N.GT.0)I=MAX+MIN-M
      IARRAY(I+N)=IARRAY(I)
10    CONTINUE
      RETURN
      END
C-- F77LCF      F77LCFC.FOR                           7/09/84    JWC
C
C
      SUBROUTINE LCFSTP(NL,LOOK,LLAB,LABLS,NCOLS,LOOKUP,NLOOK,
     * IN,IOUT,LBUF)
C     ========================================================
C
C This subroutine is used to set up the  lookup table of column
C numbers for the required data items based on the program labels.
C the subroutine reads and interprets the lcf column assignments
C from the control data
C
C---- Parameters
C
C          NL (I)   THE NUMBER OF CHARACTERS IN THE ARRAY 'LOOK' WHICH
C                   CONTAINS THE NAMES OF THE DATA ITEMS REQUIRED BY
C                   THE PROGRAM. -NL MAY BE GIVEN IF OPTIONAL COLUMN
C                   ASSIGNMENTS ARE TO BE USED (SEE 'LOOKUP' BELOW)
C        LOOK (I)   CHARACTER ARRAY CONTAINING THE PROGRAM LABELS FOR
C                   THE DATA ITEMS REQUIRED BY THE PROGRAM.
C        LLAB (I)   LENGTH OF THE ARRAY HOLDING COLUMN LABELS
C       LABLS (I)   CHARACTER ARRAY HOLDING THE COLUMN LABELS
C      LOOKUP (I/O) THIS ARRAY RETURNS THE POSITIONS OF THE REQUESTED
C                   DATA ITEMS. IF 'NL' IS NEGATIVE THEN, ON ENTRY
C                   TO THE SUBROUTINE, THE ENTRIES IN 'LOOKUP' MUST
C                   BE SET TO 0 FOR OPTIONAL COLUMNS AND -1 FOR
C                   COMPULSORY COLUMNS. IF NL > 0 THEN ALL COLUMNS ARE
C                   TREATED AS COMPULSORY.
C       NLOOK (O)   RETURNS THE NUMBER OF PROGRAM LABELS
C          IN (I)   UNIT FOR READING LCF ASSIGNMENTS
C        IOUT (I)   UNIT FOR PRINTER OUTPUT
C        LBUF (I)   LENGTH OF BUFFER FOR ASSIGNMENTS READ (72 OR 80)
C
C---- Specification statements
C
      LOGICAL FSOFT,LBLERR
      CHARACTER*1 LOOK(*),LABLS(LLAB),BUF(80)
      DIMENSION LOOKUP(100),IUASS(100)
C
C---- Set soft fail flag
C
      FSOFT=.FALSE.
      IF(NL.LT.0)FSOFT=.TRUE.
      LKL=IABS(NL)
      LBLERR=.FALSE.
C
C---- Find 'NLOOK', the number of program labels
C
      CALL LCFITM(LOOK,LKL,NLOOK)
20    IF(NLOOK.EQ.0)RETURN
      IF(NLOOK.GT.100)GO TO 800
      IF(FSOFT)GO TO 50
C
C---- If no soft fail, set all columns to compulsory
C
      DO 30 I=1,NLOOK
      LOOKUP(I)=-1
30    CONTINUE
C
C---- Read column assignments
C
50    READ(IN,1001,END=200)(BUF(L),L=1,LBUF)
      I=0
60    I=I+1
      CALL LCFASG(I,BUF,LBUF,IP1,IP2,IL1,IL2,*50,*200,*600)
C
C---- Look for program label
C
      DO 110 N=1,NLOOK
      CALL LCFLBL(N,LOOK,LKL,MIN,MAX,*110)
      IF(LCFCMP(LOOK,MIN,MAX,BUF,IP1,IP2).EQ.1)GO TO 130
110   CONTINUE
      GO TO 610
C
C---- Look for column label
C
130   DO 140 M=1,NCOLS
      CALL LCFLBL(M,LABLS,LLAB,MIN,MAX,*140)
      IF(LCFCMP(LABLS,MIN,MAX,BUF,IL1,IL2).EQ.1)GO TO 160
140   CONTINUE
      LBLERR=.TRUE.
      GO TO 810
C
C---- See if program label already assigned, set 'lookup' entry
C
160   IF(LOOKUP(N).GT.0)GO TO 620
170   LOOKUP(N)=M
      GO TO 60
C
C---- All assignments read; check unassigned columns
C
200   IF(LBLERR)GO TO 820
      LBLERR=.FALSE.
      K=0
      DO 350 I=1,NLOOK
      IF(LOOKUP(I).GT.0)GO TO 350
      K=K+1
      IUASS(K)=I
      CALL LCFLBL(I,LOOK,LKL,IP1,IP2,*350)
      DO 320 N=1,NCOLS
      CALL LCFLBL(N,LABLS,LLAB,MIN,MAX,*320)
      IF(LCFCMP(LABLS,MIN,MAX,LOOK,IP1,IP2).EQ.1)GO TO 340
320   CONTINUE
      IF(LOOKUP(I).LT.0)LBLERR=.TRUE.
      GO TO 350
340   LOOKUP(I)=N
350   CONTINUE
C
C---- Print details of results of assignments
C
      WRITE(IOUT,1002)(IUASS(I),I=1,K)
      WRITE(IOUT,1003)
      CALL LCFPRT(IOUT,LOOK,1,LKL,1,80)
      WRITE(IOUT,1004)
      CALL LCFPRT(IOUT,LABLS,1,LLAB,1,80)
      WRITE(IOUT,1005)(LOOKUP(I),I=1,NLOOK)
      IF(LBLERR)GO TO 830
      RETURN
C
C---- Warnings
C
600   WRITE(IOUT,2001)
      WRITE(IOUT,2002)(BUF(J),J=IP1,IL2)
      GO TO 60
610   WRITE(IOUT,2001)
      WRITE(IOUT,2003)(BUF(J),J=IP1,IP2)
      GO TO 60
620   WRITE(IOUT,2001)
      WRITE(IOUT,2004)(BUF(J),J=IP1,IP2)
      GO TO 60
C
C---- Error conditions causing immediate or eventual program termination
C
800   WRITE(IOUT,3001)
      WRITE(IOUT,3002)
      WRITE(IOUT,3010)
          call ccperr(1,' stop in lcflib.for 1800')
810   WRITE(IOUT,3001)
      WRITE(IOUT,3003)(BUF(J),J=IL1,IL2)
      GO TO 60
820   WRITE(IOUT,3001)
      WRITE(IOUT,3004)
      WRITE(IOUT,3010)
          call ccperr(1,' stop in lcflib.for 1820')
830   WRITE(IOUT,3001)
      WRITE(IOUT,3005)
      WRITE(IOUT,3010)
          call ccperr(1,' stop in lcflib.for 1830')
C
C---- Format statements
C
1001  FORMAT(80A1)
1002  FORMAT(/,' * POSITIONAL NUMBERS OF UNASSIGNED COLUMN LABELS:',
     *(//,1X,15I5))
1003  FORMAT(/,' * PROGRAM LABELS:',/)
1004  FORMAT(/,' * COLUMN LABELS:',/)
1005  FORMAT(/,' * LOOKUP TABLE:',(//,1X,15I5))
2001  FORMAT(/,' *LCF WARNING*')
2002  FORMAT(' *INVALID ASSIGNMENT IGNORED* : ',40A1,(/,1X,80A1))
2003  FORMAT(' *UNUSED PROGRAM LABEL IGNORED* : ',40A1,(/,1X,80A1))
2004  FORMAT(' *PROGRAM LABEL ALREADY ASSIGNED* : ',40A1,(/,1X,80A1))
3001  FORMAT(/,' **LCF ERROR**')
3002  FORMAT(' **MAXIMUM ALLOWED NUMBER OF PROGRAM LABELS IS 100**')
3003  FORMAT(' **COLUMN LABEL NOT FOUND** : ',40A1,(/,1X,80A1))
3004  FORMAT(' **MISSING COLUMN LABELS**')
3005  FORMAT(' **UNASSIGNED COMPULSORY COLUMN LABELS (-1 IN LOOKUP)**')
3010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C
      SUBROUTINE NLCHK1(NCO)
C     ======================
C
C Check that the number of columns to be output is the number
C of columns with which the file was opened
C
C
C---- Parameters
C
C         NCO (I)   NO. OF COLUMNS TO BE OUTPUT
C
C---- Specification statements and code
C
      LOGICAL RD
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1WK/
C
C
      IF(NCO.EQ.NCOUT)RETURN
      WRITE(IOUT,2001)NCO,NCOUT
          call ccperr(1,' stop in lcflib.for 2000')
C
C---- Format statements
C
2001  FORMAT(/,' **LCF ERROR**',//,
     * ' **',I4,' COLUMNS TO BE WRITTEN,',I3,' DEFINED**',//,
     * ' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'NLCHK2'
C ===================
C
C CHECK THAT THE NUMBER OF COLUMNS TO BE OUTPUT IS THE NUMBER
C OF COLUMNS WITH WHICH THE FILE WAS OPENED
C
      SUBROUTINE NLCHK2(NCO)
C
C PARAMETERS
C
C         NCO (I)   NO. OF COLUMNS TO BE OUTPUT
C
C SPECIFICATION STATEMENTS AND CODE
C
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2WK/
      IF(NCO.EQ.NCOUT)RETURN
      WRITE(IOUT,2001)NCO,NCOUT
          call ccperr(1,' stop in lcflib.for 2001')
C
C FORMAT STATEMENTS
C
2001  FORMAT(/,' **LCF ERROR**',//,
     * ' **',I4,' COLUMNS TO BE WRITTEN,',I3,' DEFINED**',//,
     * ' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'ORPAK1'
C ===================
C
C THIS SUBROUTINE IS USED TO TRANSFER ORIENTATION DATA TO AND FROM A
C REFLECTION DATA RECORD OF AN LCF FILE
C
C  ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
C VERSION FOR 2 BYTES/COLUMN; ALLOWS INPUT OF OLD DEFINITION
C ORIENTATION DATA (MIXED INTEGER*2 AND REAL VALUES)
C
      SUBROUTINE ORPAK1(IDATA,MIN,MAX,ORDATA,NWORD,LL,IRW,*)
C
C PARAMETERS
C
C       IDATA (I/O) INTEGER ARRAY FOR REFLECTION RECORD
C         MIN (I)   NO. OF FIRST COLUMN FOR ORIENTATION DATA
C         MAX (I)   NO. OF FINAL COLUMN FOR ORIENTATION DATA
C      ORDATA (I/O) ARRAY WITH ORIENATION DATA (FULL WORD ARRAY IN
C                   CALLING PROGRAM)
C      NWORDH (I)   NUMBER OF WORDS IN ORDATA
C          LL (I/O) SET TO 0 ON FIRST CALL AND SUBSEQUENTLY LEAVE
C                   AS RETURNED FROM PREVIOUS CALL (RESET IF O NEW
C                   ORIENTAION BLOCK IS BEING READ OR WRITTEN)
C         IRW (I)   =1, TRANSFER FROM IDATA TO ORDATA
C                   =2, TRANSFER FROM ORDATA TO IDATA
C
C IF IRW=1  RETURN 1 IF ALL OF ORIENTATION DATA ARRAY READ
C IF IRW=2  RETURN 1 IF NO DATA TRANSFER PERFORMED
C
C SPECIFICATION STATEMENTS
C
      INTEGER IDATA(*)
      INTEGER*2 ORDATA(*)
      INTEGER*2 LOFFST(86)
      INTEGER*2 JDATA(2)
      LOGICAL OLD
      COMMON /ORPKX1/OLD,NWRDS,NW2
      EQUIVALENCE (KDATA,JDATA(1))
      SAVE /ORPKX1/
      DATA LOFFST/-1,3,4,5,6,7,8,9,10,11,
     *  12,13,14,-15,-17,-19,-21,-23,-25,27,
     *  28,29,30,31,32,33,34,35,36,37,
     *  38,39,40,41,42,43,44,-45,47,48,
     *  49,50,51,52,53,54,55,56,57,58,
     *  59,60,61,62,63,64,-65,-67,69,70,
     *  71,72,73,74,75,76,77,78,79,80,
     *  81,82,83,84,85,86,-87,-89,-91,-93,
     *  -95,-97,-99,-101,-103,-105/
C
C SELECT OPTION
C
      IF(LL.EQ.0)NW2=2*NWORD
      GO TO(100,200),IRW
C
C COPY FROM RECORD BUFFER TO ORIENTATION DATA ARRAY
C
100   IF(LL.GT.0)GO TO 110
      OLD=.FALSE.
      IF(IDATA(MIN+1).EQ.0)GO TO 110
      OLD=.TRUE.
      NW2=IDATA(MIN)/2
110   DO 150 M=MIN,MAX
      LL=LL+1
      K=LL
      IF(OLD)K=LOFFST(LL)
      IF(K.LT.0)GO TO 120
      ORDATA(K)=IDATA(M)
      GO TO 130
120   K=-K
      KDATA=IDATA(M)
      ORDATA(K)=JDATA(1)
      ORDATA(K+1)=JDATA(2)
130   NWRDS=(K+1)/2
      IF(LL.GE.NW2)THEN
	    IF(OLD) THEN
		  ORDATA(1)=NWRDS
		  ORDATA(2)=0
	    ENDIF
	    RETURN 1
      ENDIF
150   CONTINUE
      RETURN
C
C COPY FROM ORIENTATION DATA ARRAY TO RECORD BUFFER
C
200   DO 210 M=MIN,MAX
      LL=LL+1
      IF(LL.GT.NW2)GO TO 220
      IDATA(M)=ORDATA(LL)
210   CONTINUE
      RETURN
220   IF(M.EQ.MIN)RETURN 1
      RETURN
      END
C
C SUBROUTINE 'ORPAK1'
C ===================
C
C THIS SUBROUTINE IS USED TO TRANSFER ORIENTATION DATA TO AND FROM A
C REFLECTION DATA RECORD OF AN LCF FILE
C
C  ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
C VERSION FOR 2 BYTES/COLUMN; ALLOWS INPUT OF OLD DEFINITION
C ORIENTATION DATA (MIXED INTEGER*2 AND REAL VALUES)
C
      SUBROUTINE ORPAK2(IDATA,MIN,MAX,ORDATA,NWORD,LL,IRW,*)
C
C PARAMETERS
C
C       IDATA (I/O) INTEGER ARRAY FOR REFLECTION RECORD
C         MIN (I)   NO. OF FIRST COLUMN FOR ORIENTATION DATA
C         MAX (I)   NO. OF FINAL COLUMN FOR ORIENTATION DATA
C      ORDATA (I/O) ARRAY WITH ORIENATION DATA (FULL WORD ARRAY IN
C                   CALLING PROGRAM)
C      NWORDH (I)   NUMBER OF WORDS IN ORDATA
C          LL (I/O) SET TO 0 ON FIRST CALL AND SUBSEQUENTLY LEAVE
C                   AS RETURNED FROM PREVIOUS CALL (RESET IF O NEW
C                   ORIENTAION BLOCK IS BEING READ OR WRITTEN)
C         IRW (I)   =1, TRANSFER FROM IDATA TO ORDATA
C                   =2, TRANSFER FROM ORDATA TO IDATA
C
C IF IRW=1  RETURN 1 IF ALL OF ORIENTATION DATA ARRAY READ
C IF IRW=2  RETURN 1 IF NO DATA TRANSFER PERFORMED
C
C SPECIFICATION STATEMENTS
C
      INTEGER IDATA(*)
      INTEGER*2 ORDATA(*)
      INTEGER*2 LOFFST(86)
      INTEGER*2 JDATA(2)
      LOGICAL OLD
      COMMON /ORPKX2/OLD,NWRDS,NW2
      EQUIVALENCE (KDATA,JDATA(1))
      SAVE /ORPKX2/
      DATA LOFFST/-1,3,4,5,6,7,8,9,10,11,
     *  12,13,14,-15,-17,-19,-21,-23,-25,27,
     *  28,29,30,31,32,33,34,35,36,37,
     *  38,39,40,41,42,43,44,-45,47,48,
     *  49,50,51,52,53,54,55,56,57,58,
     *  59,60,61,62,63,64,-65,-67,69,70,
     *  71,72,73,74,75,76,77,78,79,80,
     *  81,82,83,84,85,86,-87,-89,-91,-93,
     *  -95,-97,-99,-101,-103,-105/
C
C SELECT OPTION
C
      IF(LL.EQ.0)NW2=2*NWORD
      GO TO(100,200),IRW
C
C COPY FROM RECORD BUFFER TO ORIENTATION DATA ARRAY
C
100   IF(LL.GT.0)GO TO 110
      OLD=.FALSE.
      IF(IDATA(MIN+1).EQ.0)GO TO 110
      OLD=.TRUE.
      NW2=IDATA(MIN)/2
110   DO 150 M=MIN,MAX
      LL=LL+1
      K=LL
      IF(OLD)K=LOFFST(LL)
      IF(K.LT.0)GO TO 120
      ORDATA(K)=IDATA(M)
      GO TO 130
120   K=-K
      KDATA=IDATA(M)
      ORDATA(K)=JDATA(1)
      ORDATA(K+1)=JDATA(2)
130   NWRDS=(K+1)/2
      IF(LL.GE.NW2)THEN
	    IF(OLD) THEN
		  ORDATA(1)=NWRDS
		  ORDATA(2)=0
	    ENDIF
	    RETURN 1
      ENDIF
150   CONTINUE
      RETURN
C
C COPY FROM ORIENTATION DATA ARRAY TO RECORD BUFFER
C
200   DO 210 M=MIN,MAX
      LL=LL+1
      IF(LL.GT.NW2)GO TO 220
      IDATA(M)=ORDATA(LL)
210   CONTINUE
      RETURN
220   IF(M.EQ.MIN)RETURN 1
      RETURN
      END
C
C
C SUBROUTINE 'PLLCF1'
C ===================
C
C THIS SUBROUTINE IS USED TO PRINT THE COLUMN LABELS FROM THE
C COMMON BLOCK 'LCF1AR' USED WITH THE STANDARD 'LCF' ROUTINES
C
      SUBROUTINE PLLCF1(LUN,MINCOL,MAXCOL)
C
C PARAMETERS
C
C         LUN (I) THE UNIT NUMBER FOR PRINTING
C      MINCOL (I) THE NUMBER OF THE FIRST COLUMN OF THE PRINT FIELD
C                 TO BE USED
C      MAXCOL (I) THE NUMBER OF THE FINAL COLUMN OF THE PRINT FIELD
C                 TO BE USED
C
C SPECIFICATION STATEMENTS AND CODE
C
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      SAVE /LCF1/,/LCF1AR/
      MIN=1
      MAX=LABELN
      CALL LCFPRT(LUN,ARRAYN,MIN,MAX,MINCOL,MAXCOL)
      RETURN
      END
C
C
C SUBROUTINE 'PLLCF2'
C ===================
C
C THIS SUBROUTINE IS USED TO PRINT THE COLUMN LABELS FROM THE
C COMMON BLOCK 'LCF2AR' USED WITH THE STANDARD 'LCF' ROUTINES
C
      SUBROUTINE PLLCF2(LUN,MINCOL,MAXCOL)
C
C PARAMETERS
C
C         LUN (I) THE UNIT NUMBER FOR PRINTING
C      MINCOL (I) THE NUMBER OF THE FIRST COLUMN OF THE PRINT FIELD
C                 TO BE USED
C      MAXCOL (I) THE NUMBER OF THE FINAL COLUMN OF THE PRINT FIELD
C                 TO BE USED
C
C SPECIFICATION STATEMENTS AND CODE
C
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      SAVE /LCF2/,/LCF2AR/
      MIN=1
      MAX=LABELN
      CALL LCFPRT(LUN,ARRAYN,MIN,MAX,MINCOL,MAXCOL)
      RETURN
      END
C
C
C SUBROUTINE 'PTLCF1'
C ===================
C
C THIS SUBROUTINE IS USED TO PRINT THE TITLE FROM THE
C COMMON BLOCK 'LCF1AR' USED WITH THE STANDARD 'LCF' ROUTINES
C
      SUBROUTINE PTLCF1(LUN,MINCOL,MAXCOL)
C
C PARAMETERS
C
C         LUN (I) THE UNIT NUMBER FOR PRINTING
C      MINCOL (I) THE NUMBER OF THE FIRST COLUMN OF THE PRINT FIELD
C                 TO BE USED
C      MAXCOL (I) THE NUMBER OF THE FINAL COLUMN OF THE PRINT FIELD
C                 TO BE USED
C
C SPECIFICATION STATEMENTS AND CODE
C
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      SAVE /LCF1AR/
      MIN=LABELN+1
      MAX=LABELN+LTITN
      CALL LCFPRT(LUN,ARRAYN,MIN,MAX,MINCOL,MAXCOL)
      RETURN
      END
C
C
C SUBROUTINE 'PTLCF2'
C ===================
C
C THIS SUBROUTINE IS USED TO PRINT THE TITLE FROM THE
C COMMON BLOCK 'LCF2AR' USED WITH THE STANDARD 'LCF' ROUTINES
C
      SUBROUTINE PTLCF2(LUN,MINCOL,MAXCOL)
C
C PARAMETERS
C
C         LUN (I) THE UNIT NUMBER FOR PRINTING
C      MINCOL (I) THE NUMBER OF THE FIRST COLUMN OF THE PRINT FIELD
C                 TO BE USED
C      MAXCOL (I) THE NUMBER OF THE FINAL COLUMN OF THE PRINT FIELD
C                 TO BE USED
C
C SPECIFICATION STATEMENTS AND CODE
C
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      SAVE /LCF2/,/LCF2AR/
      MIN=LABELN+1
      MAX=LABELN+LTITN
      CALL LCFPRT(LUN,ARRAYN,MIN,MAX,MINCOL,MAXCOL)
      RETURN
      END
C
C
      SUBROUTINE PTORN1(IBATCH)
C     =========================
C
C This subroutine prints the orientation data for the current
C batch (as read via GTORN1)
C
C
C---- Parameters
C
C      IBATCH (I)   BATCH NUMBER
C
C---- Specification statements
C
      LOGICAL RD
      COMMON /ORIENT/ NWORDS,CELL(6),LCELL(6),UMATR(3,3),JUMPAX,
     .  PHXYZ(3,2),DELRAX,PHISTT,PHIEND,IFTCRD,ETAD,ALAMBD,
     .  DELLAM,DELCOR,DIVHD,DIVVD,BSCALE,BBFAC,SDBSC,SDBB,
     .  NRAST,IRASTR(9)
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*2 ABC(3)
      CHARACTER*4 AXIS(5,2),BLANK
      SAVE /ORIENT/,/LCF1WK/
      DATA ABC/'A*','B*','C*'/
      DATA AXIS/5*'    ','DIFF','RACT','OMET','ER  ','    '/
      DATA BLANK/'    '/
C
C---- Print orientation data (diffractometer data has jumpax.le.0)
C     if jumpax .ge. 100, treat as area detector block
C
      IF(JUMPAX.GE.100) THEN
	    CALL PTORNA(IBATCH)
	    RETURN
      ENDIF
C
      IF(JUMPAX.LE.0) GO TO 10
      AXIS(1,1)=ABC(JUMPAX)
      K=1
      GO TO 20
C
10    K=2
      AXIS(5,2)=BLANK
      IF(JUMPAX.LT.0) AXIS(5,2)=ABC(-JUMPAX)
C  
20    WRITE(IOUT,1000) IBATCH,CELL,LCELL,((UMATR(I,J),J=1,3),I=1,3),
     .  (AXIS(I,K),I=1,5),PHXYZ,PHISTT,PHIEND,ETAD,ALAMBD,DELLAM,
     .  DELCOR,DIVHD,DIVVD,BSCALE,BBFAC,SDBSC,SDBB
      RETURN
C
C---- Format statements
C
1000  FORMAT(/1X,20('++++')//' Orientation data for batch',I8//
     . ' Cell dimensions ...................',6F7.2/
     . ' Cell fix flags ....................',6I7/
     . ' Orientation matrix U ..............',3F10.4,2(/36X,3F10.4)/
     . ' Mounting axis .....................',5X,5A4/
     . ' Missetting angles phi xyz .........',6F7.2/
     . ' Start and stop phi angles .........',2F7.2/
     . ' Mosaicity .........................',F7.3/
     . ' Wavelength and dispersion .........',3F10.6/
     . ' Divergence ........................',2F7.3/
     . ' Batch scale and temperature factor ',2F7.3/
     . '     standard deviations ...........',2F7.3//
     . 1X,20('++++')/)
      END
C
C SUBROUTINE 'PTORN2'
C ===================
C
C THIS SUBROUTINE PRINTS THE ORIENTATION DATA FOR THE CURRENT
C BATCH (AS READ VIA GTORN2)
C
      SUBROUTINE PTORN2(IBATCH)
C
C PARAMETERS
C
C      IBATCH (I)   BATCH NUMBER
C
C SPECIFICATION STATEMENTS
C
      COMMON /ORIENT/ NWORDS,CELL(6),LCELL(6),UMATR(3,3),JUMPAX,
     .  PHXYZ(3,2),DELRAX,PHISTT,PHIEND,IFTCRD,ETAD,ALAMBD,
     .  DELLAM,DELCOR,DIVHD,DIVVD,BSCALE,BBFAC,SDBSC,SDBB,
     .  NRAST,IRASTR(9)
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*2 ABC(3)
      CHARACTER*4 AXIS(5,2),BLANK
      SAVE /ORIENT/,/LCF2WK/
      DATA ABC/'A*','B*','C*'/
      DATA AXIS/5*'    ','DIFF','RACT','OMET','ER  ','    '/
      DATA BLANK/'    '/
C
C PRINT ORIENTATION DATA (DIFFRACTOMETER DATA HAS JUMPAX.LE.0)
C If JUMPAX .ge. 100, treat as area detector block
      IF(JUMPAX.GE.100) THEN
	    CALL PTORNA(IBATCH)
	    RETURN
      ENDIF
C
      IF(JUMPAX.LE.0) GO TO 10
      AXIS(1,1)=ABC(JUMPAX)
      K=1
      GO TO 20
C
10    K=2
      AXIS(5,2)=BLANK
      IF(JUMPAX.LT.0) AXIS(5,2)=ABC(-JUMPAX)
C
20    WRITE(IOUT,1000) IBATCH,CELL,LCELL,((UMATR(I,J),J=1,3),I=1,3),
     .  (AXIS(I,K),I=1,5),PHXYZ,PHISTT,PHIEND,ETAD,ALAMBD,DELLAM,
     .  DELCOR,DIVHD,DIVVD,BSCALE,BBFAC,SDBSC,SDBB
      RETURN
C
C FORMAT STATEMENTS
C
1000  FORMAT(/1X,20('++++')//' Orientation data for batch',I8//
     . ' Cell dimensions ...................',6F7.2/
     . ' Cell fix flags ....................',6I7/
     . ' Orientation matrix U ..............',3F10.4,2(/36X,3F10.4)/
     . ' Mounting axis .....................',5X,5A4/
     . ' Missetting angles phi xyz .........',6F7.2/
     . ' Start and stop phi angles .........',2F7.2/
     . ' Mosaicity .........................',F7.3/
     . ' Wavelength and dispersion .........',3F10.6/
     . ' Divergence ........................',2F7.3/
     . ' Batch scale and temperature factor ',2F7.3/
     . '     standard deviations ...........',2F7.3//
     . 1X,20('++++')/)
      END
C
C
	SUBROUTINE PTORNA(IBATCH)
C	=========================
C
C Print area detector orientation block
C
C
C
C Orientation block data                
C  This contains slots for all information that seems to be essential
C  at present, plus some space and flexibility flags for future expansion
C  It doesn't really seem necessary to carry through a whole lot of crystal
C  and beam tensors, particularly now we have integrated intensities, but
C  maybe someone will want to.
C
C  NWORDS	number of words in orientation block
C
C--- Information for this crystal
C  CELL(6)	cell dimensions  (A & degrees)
C  LCELL(6)	refinement flags for cell dimensions
C  U(3,3)	orientation matrix     
C  JUMPAX      	100 + reciprocal axis closest to principle goniostat axis e1
C		  JUMPAX >=100 is used as a flag for this type of
C		  orientation block
C  ICRYST       crystal number: a crystal may contain several batches
C  LCRFLG       type of crystal mosaicity information (=0 for isotropic)
C  ETAD	        reflection width (full width) (degrees)  (if LCRFLG=0)
C  DUM1(19)     space for future expansion
C
C--- Information for this batch
C  DATUM(3)	datum values of goniostat axes, from which psi is measured
C			(degrees)
C  PSI1,PSI2	start & stop values of Psi (= Madnes Phi) (degrees)
C  JSCAXS	goniostat axis number for scanning (=1,2,3, or=0 for
C		  multiple axis scan
C  SCANAX(3)	rotation axis in laboratory frame (not yet implemented:
C		  only relevant if JSCAXS=0)
C  TIME1, TIME2 start & stop times in minutes
C  DUM2(20)	space for future expansion
C
C--- Crystal goniostat information
C  NGONAX	number of goniostat axes (normally 3)
C  E1(3),E2(3),E3(3) vectors (in "Cambridge" laboratory frame) defining
C		  the NGONAX goniostat axes
C  LABELS(6) == GONLAB(3)  names of the three goniostat axes
C  DUM3(20)	space for future expansion
C
C--- Beam information
C  SOURCE(3)    Idealized (ie excluding tilts) source vector (antiparallel
C		 to beam), in "Cambridge" laboratory frame
C  S0(3)	Source vector (antiparallel ! to beam), in 
C		 "Cambridge" laboratory frame, including tilts
C  LBMFLG       flag for type of beam information following (=0 for as follows)
C  ALAMBD	Wavelength in Angstroms
C  DELLM1	dispersion Deltalambda / lambda.
C  DELCOR	Correlated component of wavelength dispersion.
C  DIVHD 	Horizontal beam divergence in degrees.
C  DIVVD    	Vertical beam divergence (may be 0.0 for isotropic beam
C                divergence.
C  DUM4(20)	space for future expansion
C
C--- Detector information
C  NDET		number of detectors
C
C -- for each detector
C  DX		crystal to detector distance (mm)
C  THETA	detector tilt angle (=tau2) (degrees)
C  DETLIM(2,2)  minimum & maximum values of detector coordinates (pixels)
C      		  (i,j): i = 1 minimum, = 2 maximum
C		         j = 1 Ydet,    = 2 Zdet
C
C -- + space for additional information
C
C Data in the orientation block, and all workings in this program,
C  are referred to the "Cambridge" laboratory axis frame: x along the
C  X-ray beam, z along E1 (omega). The matrix Q converts a vector in
C  the Madnes frame to the Cambridge frame. Note that the laboratory
C  frame is essentially defined by the vectors e1,e2,e3 & source
C
C  
	COMMON /ORIENT/ NWORDS,CELL(6),LCELL(6),U(3,3),JUMPAX,
     .   ICRYST,LCRFLG,ETAD,DUM1(19),
     .   DATUM(3),PSI1,PSI2,JSCAXS,SCANAX(3),TIME1,TIME2,DUM2(20),
     .   NGONAX,E1(3),E2(3),E3(3),LABELS(6),DUM3(20),
     .   SOURCE(3),S0(3),LBMFLG,ALAMBD,DELLM1,DELCOR,DIVHD,DIVVD,
     .    DUM4(20),
     .   NDET,DX,THETA,DETLIM(2,2)
	INTEGER NWORDS,LCELL,JUMPAX,ICRYST,LCRFLG,JSCAXS,NGONAX,
     .   LABELS,LBMFLG,NDET
	REAL CELL,U,ETAD,DUM1,DATUM,PSI1,PSI2,SCANAX,TIME1,TIME2,
     .   DUM2,E1,E2,E3,DUM3,SOURCE,S0,ALAMBD,DELLM1,DELCOR,
     .   DIVHD,DIVVD,DUM4,DX,THETA,DETLIM
	INTEGER IBATCH
        LOGICAL RD
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
	CHARACTER*8 GONLAB(3)
	CHARACTER*4 AXES(4)      
	INTEGER I,J,K,JX,IOUT
	DATA AXES/'none','a*','b*','c*'/
C
C---- Convert labels for printing
C
	DO 1,I=1,3
	K=2*I-1    
	WRITE(GONLAB(I),101) (LABELS(J),J=K,K+1)
101	FORMAT(2A4)
1	CONTINUE
C
	JX=JUMPAX-99
C                  
      WRITE(IOUT,1000) IBATCH,ICRYST,(CELL(I),I=1,6),
     . (LCELL(I),I=1,6),((U(I,J),J=1,3),I=1,3),
     . GONLAB(1),AXES(JX),ETAD,DATUM,PSI1,PSI2,TIME1,TIME2
      WRITE(IOUT,1001) NGONAX,GONLAB(1),E1,GONLAB(2),E2,GONLAB(3),E3,
     . (SOURCE(I),I=1,3),(S0(I),I=1,3),ALAMBD,DELLM1,DELCOR,DIVHD,DIVVD
      WRITE(IOUT,1002) NDET,DX,THETA,((DETLIM(I,J),J=1,2),I=1,2)
C                                                      
      RETURN
C
C---- Format statements
C
1000  FORMAT(/20('++++'),//,
     . '   Orientation data for batch',I8,5X,'Area detector data',//,
     . '   Crystal number ....................',I7,/,
     . '   Cell dimensions ...................',6F7.2,/,
     . '   Cell fix flags ....................',6I7,/,
     . '   Orientation matrix U ..............',3F10.4,2(/38X,3F10.4),/,
     . '   Reciprocal axis nearest ',A8,'...',1X,A4,/,
     . '   Mosaicity .........................',F7.3,/,
     . '   Datum goniostat angles (degrees)...',F8.3,2F9.3,/,
     . '   Start & stop psi angles (degrees)..',2F9.3,/,
     . '   Start & stop time (minutes)........',2F9.0,/)
1001  FORMAT (' Crystal goniostat information :-',/,
     . '   Number of goniostat axes...........',I7,/,
     . '   Goniostat vectors.....',A8,'.....',3F9.4,/,
     . '                    .....',A8,'.....',3F9.4,/,
     . '                    .....',A8,'.....',3F9.4,/,
     . ' Beam information :-',/,
     . '   Idealized X-ray beam vector........',3F9.4,/,
     . '   X-ray beam vector with tilts.......',3F9.4,/,
     . '   Wavelength and dispersion .........',3F10.6,/,
     . '   Divergence ........................',2F7.3,/)
1002  FORMAT (' Detector information :-',/,
     . '   Number of detectors................',I7,/,
     . '   Crystal to Detector distance (mm)..',F9.3,/,
     . '   Detector swing angle...............',F9.3,/,
     . '   Pixel limits on detector...........',4F7.1,//,
     . 20('++++'),/)
	END
C
C SUBROUTINE 'RDLCF1'
C ===================
C
C THIS SUBROUTINE READS A REFLECTION RECORD FROM AN LCF FILE
C RETURNING THOSE ITEMS REQUESTED VIA THE PROGRAM LABELS PASSED
C TO THE SUBROUTINE 'RHLCF1' WHEN THE FILE WAS OPENED
C
      SUBROUTINE RDLCF1(IDATA,*,*)
C
C PARAMETERS
C
C       IDATA (O)   ARRAY RETURNING THE REQUESTED ITEMS FROM THE
C                   REFLECTION RECORD. THE ORDER AND NUMBER OF ITEMS
C                   DEPEND ON THE CONTENTS OF THE ARRAY 'LOOK' PASSED
C                   TO 'SRLCF1' OR 'RHLCF1' AND 'IDATA' MUST BE
C                   DIMENSIONED ACCORDINGLY.
C
C   RETURN 1   RETURN  IF FILE READING ERROR
C   RETURN 2   RETURN IF END OF FILE ENCOUNTERED
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD
      DIMENSION IDATA(*),JDATA(100)
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1WK/
C
C READ REFLECTION RECORD AND USE LOOK UP TABLE TO RETURN
C REQUESTED ITEMS
C
      IF(.NOT.RD)GO TO 800
      CALL RLCF1(JDATA,*100,*110)
      DO 50 N=1,NLOOK
      IP=IPOINT(N)
      IF(IP.LE.0)GO TO 50
      IDATA(N)=JDATA(IP)
50    CONTINUE
      RETURN
100   RETURN 1
110   RETURN 2
C
C ERROR CONDITION
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 2010')
C
C FORMAT STATEMENTS
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(' **RDLCF1 CALLED WITHOUT SETTING LOOKUP TABLE**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'RDLCF2'
C ===================
C
C THIS SUBROUTINE READS A REFLECTION RECORD FROM AN LCF FILE
C RETURNING THOSE ITEMS REQUESTED VIA THE PROGRAM LABELS PASSED
C TO THE SUBROUTINE 'RHLCF2' WHEN THE FILE WAS OPENED
C
      SUBROUTINE RDLCF2(IDATA,*,*)
C
C PARAMETERS
C
C       IDATA (O)   ARRAY RETURNING THE REQUESTED ITEMS FROM THE
C                   REFLECTION RECORD. THE ORDER AND NUMBER OF ITEMS
C                   DEPEND ON THE CONTENTS OF THE ARRAY 'LOOK' PASSED
C                   TO 'SRLCF2' OR 'RHLCF2' AND 'IDATA' MUST BE
C                   DIMENSIONED ACCORDINGLY.
C
C   RETURN 1   RETURN  IF FILE READING ERROR
C   RETURN 2   RETURN IF END OF FILE ENCOUNTERED
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD
      DIMENSION IDATA(*),JDATA(100)
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2WK/
C
C READ REFLECTION RECORD AND USE LOOK UP TABLE TO RETURN
C REQUESTED ITEMS
C
      IF(.NOT.RD)GO TO 800
      CALL RLCF2(JDATA,*100,*110)
      DO 50 N=1,NLOOK
      IP=IPOINT(N)
      IF(IP.LE.0)GO TO 50
      IDATA(N)=JDATA(IP)
50    CONTINUE
      RETURN
100   RETURN 1
110   RETURN 2
C
C ERROR CONDITION
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 3000')
C
C FORMAT STATEMENTS
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(' **RDLCF2 CALLED WITHOUT SETTING LOOKUP TABLE**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'REWIN1'
C ===================
C
C SUBROUTINE TO REWIND AN LCF FILE AND POSITION IT TO THE END
C OF THE HEADER RECORDS
C
      SUBROUTINE REWIN1
C
C PARAMETERS: NONE
C
C SPECIFICATION STATEMENTS AND CODE
C
      CHARACTER*1 BLANK
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1/,/LCF1WK/
      DATA BLANK/' '/
      IDDN=IUNIN
      CALL RHLCF1(0,BLANK,LKUP,.FALSE.)
      END
C
C SUBROUTINE 'REWIN2'
C ===================
C
C SUBROUTINE TO REWIND AN LCF FILE AND POSITION IT TO THE END
C OF THE HEADER RECORDS
C
      SUBROUTINE REWIN2
C
C PARAMETERS: NONE
C
C SPECIFICATION STATEMENTS AND CODE
C
      CHARACTER*1 BLANK
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2/,/LCF2WK/
      DATA BLANK/' '/
      IDDN=IUNIN
      CALL RHLCF2(0,BLANK,LKUP,.FALSE.)
      END
C
C SUBROUTINE 'RHLCF1'
C ===================
C
C THIS SUBROUTINE READS THE HEADER INFORMATION FROM AN INPUT FILE
C AND IF REQUIRED READS (DEFAULT UNIT=5) THE LCF COLUMN ASSIGNMENTS
C FROM THE CONTROL DATA
C
      SUBROUTINE RHLCF1(NL,LOOK,LOOKUP,IPRINT)
C
C PARAMETERS (FOR FURTHER DETAILS SEE THE DESCRIPTION OF THE
C             CORRESPONDING PARAMETERS IN THE SUBROUTINE 'SRLCF1')
C
C          NL (I)   NUMBER OF CHARACTERS IN THE ARRAY LOOK (MAY BE
C                   0 OR -NL)
C        LOOK (I)   CHARACTER ARRAY CONTAINING PROGRAM LABELS
C      LOOKUP (I/O) ARRAY RETURNING THE POSITIONS OF THE REQUESTED DATA
C                   ITEMS
C       IPRINT (I)  .TRUE. PRINT HEADER INFORMATION, =.FALSE. DO NOT
C
C THE ITEM 'IDDN' IN COMMON /LCF1/ MUST BE SET TO THE REQUIRED UNIT
C NUMBER FOR THE INPUT FILE (OR EQUIVALENT IF NON-FORTRAN I/O IS
C USED) BEFORE THE SUBROUTINE 'RHLCF1' IS CALLED.
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD,IPRINT
      CHARACTER*1 ARRAYN(1000),LOOK(*)
      DIMENSION LOOKUP(*)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1/,/LCF1AR/,/LCF1WK/
C
C INITIALISE COMMON /LCF1WK/ IF REQUIRED
C
      CALL INLCF1(5,6,72)
C
C OPEN INPUT FILE
C
      CALL LCF1OR(*800)
C
C READ HEADER RECORDS
C
      MAXDN=1000
      CALL HRLCF1(IERR)
      IF(IERR.NE.0)GO TO(805,810,815,820,825),IERR
      CALL LCFITM(ARRAYN,LABELN,NN)
      IF(NN.NE.NCIN)GO TO 830
C
C PRINT HEADER INFORMATION IF REQUIRED
C
      IF(.NOT.IPRINT)GO TO 200
      WRITE(IOUT,1001)IUNIN,NCIN
      WRITE(IOUT,1002)
      CALL LCFPRT(IOUT,ARRAYN,1,LABELN,1,80)
      WRITE(IOUT,1003)
      CALL LCFPRT(IOUT,ARRAYN,LABELN+1,LABELN+LTITN,1,80)
      WRITE(IOUT,1004)CELLN
C
C SET UP LOOKUP TABLE IF REQUIRED
C
200   IF(NL.EQ.0)RETURN
      CALL LCFSTP(NL,LOOK,LABELN,ARRAYN,NCIN,LOOKUP,NLOOK,
     *IN,IOUT,LBUF)
      IF(NLOOK.EQ.0)RETURN
C
C SET FLAG AND POINTERS FOR 'RDLCF1'
C
      RD=.TRUE.
      DO 250 N=1,NLOOK
      IPOINT(N)=LOOKUP(N)
250   CONTINUE
      RETURN
C
C ERROR CONDITIONS
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)IUNIN
      GO TO 900
805   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      GO TO 900
810   WRITE(IOUT,2001)
      WRITE(IOUT,2004)
      GO TO 900
815   WRITE(IOUT,2001)
      WRITE(IOUT,2005)
      GO TO 900
820   WRITE(IOUT,2001)
      WRITE(IOUT,2006)
      GO TO 900
825   WRITE(IOUT,2001)
      WRITE(IOUT,2007)
      GO TO 900
830   WRITE(IOUT,2001)
      WRITE(IOUT,2008)NCIN,NN
      GO TO 900
900   WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 900')
C
C FORMAT STATEMENTS
C
1001  FORMAT(//,' HEADER INFORMATION FROM INPUT LCF FILE ON UNIT',I3,
     *//,' NUMBER OF COLUMNS =',I4)
1002  FORMAT(/,' * COLUMN LABELS:',/)
1003  FORMAT(/,' * TITLE:',/)
1004  FORMAT(/,' * CELL DIMENSIONS:',//,' ',6F8.2)
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(' **ERROR IN OPENING INPUT LCF FILE ON UNIT',I3,' **')
2003  FORMAT(' **ERROR ON READING BEGINNING OF HEADER RECORD**')
2004  FORMAT(' **ERROR ON READING CELL DIMENSIONS RECORD(S)**')
2005  FORMAT(' **ERROR ON READING LABELS RECORD(S)**')
2006  FORMAT(' **ERROR ON READING TITLE RECORD(S)**')
2007  FORMAT(' **ERROR ON READING END OF HEADER RECORD**')
2008  FORMAT(' **NO. OF COLUMNS FROM HEADER =',I3,' NO. OF LABELS =',I3,
     *' **')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'RHLCF2'
C ===================
C
C THIS SUBROUTINE READS THE HEADER INFORMATION FROM AN INPUT FILE
C AND IF REQUIRED READS (DEFAULT UNIT=5) THE LCF COLUMN ASSIGNMENTS
C FROM THE CONTROL DATA
C
      SUBROUTINE RHLCF2(NL,LOOK,LOOKUP,IPRINT)
C
C PARAMETERS (FOR FURTHER DETAILS SEE THE DESCRIPTION OF THE
C             CORRESPONDING PARAMETERS IN THE SUBROUTINE 'SRLCF2')
C
C          NL (I)   NUMBER OF CHARACTERS IN THE ARRAY LOOK (MAY BE
C                   0 OR -NL)
C        LOOK (I)   CHARACTER ARRAY CONTAINING PROGRAM LABELS
C      LOOKUP (I/O) ARRAY RETURNING THE POSITIONS OF THE REQUESTED DATA
C                   ITEMS
C       IPRINT (I)  .TRUE. PRINT HEADER INFORMATION, =.FALSE. DO NOT
C
C THE ITEM 'IDDN' IN COMMON /LCF2/ MUST BE SET TO THE REQUIRED UNIT
C NUMBER FOR THE INPUT FILE (OR EQUIVALENT IF NON-FORTRAN I/O IS
C USED) BEFORE THE SUBROUTINE 'RHLCF2' IS CALLED.
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD,IPRINT
      CHARACTER*1 ARRAYN(1000),LOOK(*)
      DIMENSION LOOKUP(*)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2/,/LCF2AR/,/LCF2WK/
C
C INITIALISE COMMON /LCF2WK/ IF REQUIRED
C
      CALL INLCF2(5,6,72)
C
C OPEN INPUT FILE
C
      CALL LCF2OR(*800)
C
C READ HEADER RECORDS
C
      MAXDN=1000
      CALL HRLCF2(IERR)
      IF(IERR.NE.0)GO TO(805,810,815,820,825),IERR
      CALL LCFITM(ARRAYN,LABELN,NN)
      IF(NN.NE.NCIN)GO TO 830
C
C PRINT HEADER INFORMATION IF REQUIRED
C
      IF(.NOT.IPRINT)GO TO 200
      WRITE(IOUT,1001)IUNIN,NCIN
      WRITE(IOUT,1002)
      CALL LCFPRT(IOUT,ARRAYN,1,LABELN,1,80)
      WRITE(IOUT,1003)
      CALL LCFPRT(IOUT,ARRAYN,LABELN+1,LABELN+LTITN,1,80)
      WRITE(IOUT,1004)CELLN
C
C SET UP LOOKUP TABLE IF REQUIRED
C
200   IF(NL.EQ.0)RETURN
      CALL LCFSTP(NL,LOOK,LABELN,ARRAYN,NCIN,LOOKUP,NLOOK,
     *IN,IOUT,LBUF)
      IF(NLOOK.EQ.0)RETURN
C
C SET FLAG AND POINTERS FOR 'RDLCF2'
C
      RD=.TRUE.
      DO 250 N=1,NLOOK
      IPOINT(N)=LOOKUP(N)
250   CONTINUE
      RETURN
C
C ERROR CONDITIONS
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)IUNIN
      GO TO 900
805   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      GO TO 900
810   WRITE(IOUT,2001)
      WRITE(IOUT,2004)
      GO TO 900
815   WRITE(IOUT,2001)
      WRITE(IOUT,2005)
      GO TO 900
820   WRITE(IOUT,2001)
      WRITE(IOUT,2006)
      GO TO 900
825   WRITE(IOUT,2001)
      WRITE(IOUT,2007)
      GO TO 900
830   WRITE(IOUT,2001)
      WRITE(IOUT,2008)NCIN,NN
      GO TO 900
900   WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 9001')
C
C FORMAT STATEMENTS
C
1001  FORMAT(//,' HEADER INFORMATION FROM INPUT LCF FILE ON UNIT',I3,
     *//,' NUMBER OF COLUMNS =',I4)
1002  FORMAT(/,' * COLUMN LABELS:',/)
1003  FORMAT(/,' * TITLE:',/)
1004  FORMAT(/,' * CELL DIMENSIONS:',//,' ',6F8.2)
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(' **ERROR IN OPENING INPUT LCF FILE ON UNIT',I3,' **')
2003  FORMAT(' **ERROR ON READING BEGINNING OF HEADER RECORD**')
2004  FORMAT(' **ERROR ON READING CELL DIMENSIONS RECORD(S)**')
2005  FORMAT(' **ERROR ON READING LABELS RECORD(S)**')
2006  FORMAT(' **ERROR ON READING TITLE RECORD(S)**')
2007  FORMAT(' **ERROR ON READING END OF HEADER RECORD**')
2008  FORMAT(' **NO. OF COLUMNS FROM HEADER =',I3,' NO. OF LABELS =',I3,
     *' **')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'RLCF1'
C ==================
C
C THIS SUBROUTINE READS A REFLECTION DATA RECORD
C
C ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
      SUBROUTINE RLCF1(IDATA,*,*)
C
C PARAMETERS
C
C      IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C
C RETURN 1  RETURN FOR FILE READING ERROR
C RETURN 2  RETURN IF END OF FILE ENCOUNTERED
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      INTEGER*2 LDATA
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      COMMON /LCF1RW/LDATA(100)
      DIMENSION IDATA(NCIN)
      SAVE /LCF1WK/,/LCF1RW/
      CALL RRLCF1(LDATA,*100,*110)
      DO 10 I=1,NCIN
      IDATA(I)=LDATA(I)
10    CONTINUE
      RETURN
100   RETURN 1
110   RETURN 2
      END
C
C SUBROUTINE 'RLCF2'
C ==================
C
C THIS SUBROUTINE READS A REFLECTION DATA RECORD
C
C ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
      SUBROUTINE RLCF2(IDATA,*,*)
C
C PARAMETERS
C
C      IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C
C RETURN 1  RETURN FOR FILE READING ERROR
C RETURN 2  RETURN IF END OF FILE ENCOUNTERED
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      INTEGER*2 LDATA
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      COMMON /LCF2RW/LDATA(100)
      DIMENSION IDATA(NCIN)
      SAVE /LCF2WK/,/LCF2RW/
      CALL RRLCF2(LDATA,*100,*110)
      DO 10 I=1,NCIN
      IDATA(I)=LDATA(I)
10    CONTINUE
      RETURN
100   RETURN 1
110   RETURN 2
      END
C
C SUBROUTINE 'RRLCF1'
C ===================
C
C THIS SUBROUTINE READS A REFLECTION DATA RECORD INTO A INTEGER*2
C ARRAY
C
C ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
      SUBROUTINE RRLCF1(IDATA,*,*)
C
C PARAMETERS
C
C      IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C                  (INTEGER*2)
C
C RETURN 1  RETURN FOR FILE READING ERROR
C RETURN 2  RETURN IF END OF FILE ENCOUNTERED
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      INTEGER*2 IDATA(NCIN)
      SAVE /LCF1WK/
C
      CALL QREAD(IUNIN,IDATA,NCIN,IER)
      IF(IER.NE.0) GO TO 110
C Check for terminator
      IF(IDATA(1).EQ.32767) GO TO 110
C
      RETURN
100   RETURN 1
110   RETURN 2
C
C FORMAT STATEMENTS
C
1000  FORMAT(100A2)
      END
C
C SUBROUTINE 'RRLCF2'
C ===================
C
C THIS SUBROUTINE READS A REFLECTION DATA RECORD INTO A INTEGER*2
C ARRAY
C
C ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
      SUBROUTINE RRLCF2(IDATA,*,*)
C
C PARAMETERS
C
C      IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C                  (INTEGER*2)
C
C RETURN 1  RETURN FOR FILE READING ERROR
C RETURN 2  RETURN IF END OF FILE ENCOUNTERED
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      INTEGER*2 IDATA(NCIN)
      SAVE /LCF2WK/
C
      CALL QREAD(IUNIN,IDATA,NCIN,IER)
      IF(IER.NE.0) GO TO 110
C Check for terminator
      IF(IDATA(1).EQ.32767) GO TO 110
C
      RETURN
100   RETURN 1
110   RETURN 2
C
C FORMAT STATEMENTS
C
1000  FORMAT(100A2)
      END
C
C
      SUBROUTINE RTLCF1(IX,IDATA)
C     ===========================
C
C This subroutine reads and prints the next batch title
C
C
C---- Parameters
C
C         IX (O)   RETURNS THE BATCH NUMBER (=-1 IF THE END OF THE
C                  BATCH TITLES HAS BEEN REACHED)
C      IDATA (I/O) HOLDS THE FIRST RECORD CONTAINING THE BATCH TITLE
C                  ON INPUT. RETURNS THE LAST RECORD OF THE CURRENT
C                  BATCH TITLE OR, IF IX=-1, THE FIRST REFLECTION
C                  DATA RECORD (OR AN ORIENTATION DATA RECORD)
C
C---- Specification statements
C
      DIMENSION IDATA(*)
      CHARACTER*1 TITLE(72)
      LOGICAL RD
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      COMMON /TITLCF/TITLE
      SAVE /LCF1/,/LCF1WK/,/TITLCF/
C
C---- Read and print batch title
C
      DO 10 I=1,72
      TITLE(I)=' '
10    CONTINUE
      N1=8
      LL=0
      ISEQ=0
20    IF(IDATA(1).NE.-32750)GO TO 100
      ISEQ=ISEQ+1
      IF(ISEQ.NE.IDATA(6))GO TO 810
      IF(ISEQ.EQ.1)NCH=IDATA(7)
      IF(NCH.GT.72)GO TO 800
      CALL CHLCF1(IDATA,N1,NCIN,TITLE,NCH,LL,1,*50)
      N1=7
      CALL RLCF1(IDATA,*820,*830)
      GO TO 20
50    IX=IDATA(5)
      WRITE(IOUT,1001)IX,TITLE
      RETURN
C
C---- End of titles
C
100   IX=-1
      RETURN
C
C---- Error conditions
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)NCH
      GO TO 900
810   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      GO TO 900
820   WRITE(IOUT,2001)
      WRITE(IOUT,2004)
      GO TO 900
830   WRITE(IOUT,2001)
      WRITE(IOUT,2005)
      GO TO 900
C
C---- Terminate
C
900   WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 9003')
C
C---- Format statements
C
1001  FORMAT(5X,I5,5X,72A1)
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(/,' **INVALID NO. OF CHARACTERS IN BATCH TITLE:',I5,' **')
2003  FORMAT(/,' **BATCH TITLE RECORDS OUT OF ORDER**')
2004  FORMAT(/,' **ERROR IN READING BATCH TITLE RECORDS**')
2005  FORMAT(/,' **END OF FILE WHEN READING BATCH TITLE**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'RTLCF2'
C ===================
C
C THIS SUBROUTINE READS AND PRINTS THE NEXT BATCH TITLE
C
      SUBROUTINE RTLCF2(IX,IDATA)
C
C PARAMETERS
C
C         IX (O)   RETURNS THE BATCH NUMBER (=-1 IF THE END OF THE
C                  BATCH TITLES HAS BEEN REACHED)
C      IDATA (I/O) HOLDS THE FIRST RECORD CONTAINING THE BATCH TITLE
C                  ON INPUT. RETURNS THE LAST RECORD OF THE CURRENT
C                  BATCH TITLE OR, IF IX=-1, THE FIRST REFLECTION
C                  DATA RECORD (OR AN ORIENTATION DATA RECORD)
C
C SPECIFICATION STATEMENTS
C
      DIMENSION IDATA(*)
      CHARACTER*1 TITLE(72)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      COMMON /TITLCF/TITLE
      SAVE /LCF2/,/LCF2WK/,/TITLCF/
C
C READ AND PRINT BATCH TITLE
C
      DO 10 I=1,72
      TITLE(I)=' '
10    CONTINUE
      N1=8
      LL=0
      ISEQ=0
20    IF(IDATA(1).NE.-32750)GO TO 100
      ISEQ=ISEQ+1
      IF(ISEQ.NE.IDATA(6))GO TO 810
      IF(ISEQ.EQ.1)NCH=IDATA(7)
      IF(NCH.GT.72)GO TO 800
      CALL CHLCF2(IDATA,N1,NCIN,TITLE,NCH,LL,1,*50)
      N1=7
      CALL RLCF2(IDATA,*820,*830)
      GO TO 20
50    IX=IDATA(5)
      WRITE(IOUT,1001)IX,TITLE
      RETURN
C
C END OF TITLES
C
100   IX=-1
      RETURN
C
C ERROR CONDITIONS
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)NCH
      GO TO 900
810   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      GO TO 900
820   WRITE(IOUT,2001)
      WRITE(IOUT,2004)
      GO TO 900
830   WRITE(IOUT,2001)
      WRITE(IOUT,2005)
      GO TO 900
C
C TERMINATE
C
900   WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 9005')
C
C FORMAT STATEMENTS
C
1001  FORMAT(5X,I5,5X,72A1)
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(/,' **INVALID NO. OF CHARACTERS IN BATCH TITLE:',I5,' **')
2003  FORMAT(/,' **BATCH TITLE RECORDS OUT OF ORDER**')
2004  FORMAT(/,' **ERROR IN READING BATCH TITLE RECORDS**')
2005  FORMAT(/,' **END OF FILE WHEN READING BATCH TITLE**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C
      SUBROUTINE SKPOR1(IDATA)
C     ========================
C
C Skip orientation data from lcf file (ie read until first reflection
C record found (idata(1).gt.-32000)
C
C
C---- Parameters
C
C       IDATA(I/0)   REFLECTION RECORD DATA BUFFER
C
C---- Specification statements
C
      DIMENSION IDATA(*)
      LOGICAL RD
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1WK/
C
C---- Skip records
C
10    IF(IDATA(1).GT.-32000)RETURN
      CALL RLCF1(IDATA,*800,*810)
      GO TO 10
C
C---- Error conditions
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 90010')
810   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 90020')
C
C---- Format statements
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(/,' **ERROR IN READING WHEN SKIPPING ORIENTATION DATA**')
2003  FORMAT(/,' **END OF FILE FOUND WHEN SKIPPING ORIENTATION DATA**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'SKPOR2'
C ===================
C
C SKIP ORIENTATION DATA FROM LCF FILE (IE READ UNTIL FIRST REFLECTION
C RECORD FOUND (IDATA(1).GT.-32000)
C
      SUBROUTINE SKPOR2(IDATA)
C
C PARAMETERS
C
C       IDATA(I/0)   REFLECTION RECORD DATA BUFFER
C
C SPECIFICATION STATEMENTS
C
      DIMENSION IDATA(*)
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2WK/
C
C SKIP RECORDS
C
10    IF(IDATA(1).GT.-32000)RETURN
      CALL RLCF2(IDATA,*800,*810)
      GO TO 10
C
C ERROR CONDITIONS
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 90030')
810   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 90040')
C
C FORMAT STATEMENTS
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(/,' **ERROR IN READING WHEN SKIPPING ORIENTATION DATA**')
2003  FORMAT(/,' **END OF FILE FOUND WHEN SKIPPING ORIENTATION DATA**')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C -- F77LCF      F77MLCF1.FOR                           27/08/86    PRE
C
C
      SUBROUTINE SLLCF1(IUN,FILNAM,NL,LOOK,LCOL,IPRINT,NCOL,CELL)
C     ===========================================================
C
C This subroutine opens an lcf file and reads the header records.
C A check is made to see whether the specified column labels are
C present or not. (no assignments are read)
C
C
C---- Parameters
C
C         IUN (I)   UNIT NUMBER FOR THE INPUT FILE (OR EQUIVALENT IF
C                   NON-FORTRAN I/O IS USED)
C      FILNAM (I)   LOGICAL FILE NAME (UP TO 8 CHARACTERS)
C          NL (I)   THE NUMBER OF CHARACTERS IN THE ARRAY 'LOOK' WHICH
C                   CONTAINS THE NAMES OF STANDARD COLUMN LABELS WHICH
C                   ARE TO BE LOOKED FOR.
C        LOOK (I)   CHARACTER ARRAY CONTAINING THE COLUMN LABELS
C        LCOL (I/O) THIS ARRAY RETURNS THE POSITIONS OF THE REQUESTED
C                   DATA ITEMS. ON ENTRY TO THE SUBROUTINE THE ENTRIES
C                   IN 'LCOL' MUST BE SET TO 0 FOR OPTIONAL COLUMNS
C                   AND .LT. ZERO FOR COMPULSORY ONES. (COLUMN NUMBERS
C                   OF 0 ARE RETURNED FOR ABSENT OPTIONAL COLUMNS)
C      IPRINT (I)   FLAG =.TRUE.  PRINT (DEFAULT UNIT=6) THE CELL
C                                 DIMENSIONS, LABELS AND TITLE
C                                 INFORMATION AS READ FROM THE FILE
C                                 HEADER.
C                        =.FALSE. DO NOT PRINT THESE DETAILS
C       NCOLS (O)   RETURNS THE NUMBER OF COLUMNS OF REFLECTION
C                   DATA IN THE FILE
C        CELL (O)   6 WORD ARRAY RETURNING THE CELL DIMENSIONS
C                   IN ANGSTROMS AND DEGREES
C
C---- Specification statements
C
      LOGICAL IPRINT
      CHARACTER*(*) FILNAM
      CHARACTER*1 ARRAYN(1000),LOOK(*)
      CHARACTER*2 BLANK
      LOGICAL RD
      DIMENSION LCOL(*),CELL(6)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT
      COMMON /LCF1FN/FILIN,FILOUT
      SAVE /LCF1/,/LCF1AR/,/LCF1WK/,/LCF1FN/
      DATA BLANK/'  '/
C
C---- Open input file and read header records
C
      FILIN=FILNAM
      LFAIL=0
      IDDN=IUN
      CALL RHLCF1(2,BLANK,LCOL,IPRINT)
      DO 5 I=1,6
      CELL(I)=CELLN(I)
5     CONTINUE
      NCOL=NCIN
      IF(NCIN.GT.100)GO TO 810
      IF(NL.LE.0)RETURN
C
C---- Find the number of column labels in 'look' and in header
C
      CALL LCFITM(ARRAYN,LABELN,NLAB)
      CALL LCFITM(LOOK,NL,NLOOK)
C
C---- Search for requested column labels
C
      DO 20 J=1,NLOOK
      CALL LCFLBL(J,LOOK,NL,L1,L2,*20)
      DO 10 I=1,NLAB
      CALL LCFLBL(I,ARRAYN,LABELN,L3,L4,*10)
      IF(LCFCMP(LOOK,L1,L2,ARRAYN,L3,L4).EQ.1)GO TO 15
10    CONTINUE
C
C---- No match for this column
C
      IF(LCOL(J).EQ.0)GO TO 20
      WRITE(IOUT,2001)
      WRITE(IOUT,2002)J,(LOOK(L),L=L1,L2)
      LFAIL=LFAIL+1
      GO TO 20
C
C---- Label found
C
15    LCOL(J)=I
C
C---- End of labels loop
C
20    CONTINUE
C
C----  Set up items in common for RDLCF1
C
      RD=.TRUE.
      DO 30 J=1,NLOOK
      IPOINT(J)=LCOL(J)
30    CONTINUE
C
      IF(LFAIL.EQ.0)RETURN
      GO TO 800
C
C---- Error conditions
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      WRITE(IOUT,2004)
          call ccperr(1,' stop in lcflib.for 90050')
810   WRITE(IOUT,2001)
      WRITE(IOUT,2005)
      WRITE(IOUT,2004)
          call ccperr(1,' stop in lcflib.for 90060')
C
C---- Format statements
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(/,' **LABEL NOT FOUND FOR COMPULSORY COLUMN',I3,
     * ' **: ',40A1)
2003  FORMAT(/,' **',I3,' MISSING COMPULSORY COLUMNS IN FILE**')
2004  FORMAT(/,' **PROGRAM TERMINATED**')
2005  FORMAT(/,' **NO. OF COLS IN LCF FILE',I4,' EXCEEDS MAX OF 100**')
      END
C
C---- Last Update
C
C From: PRE@UK.AC.CAMBRIDGE.MRC-MOLECULAR-BIOLOGY  9-OCT-1989 11:25
C
C Subj: Corrected F77MLCF2.FOR, GTORN2 -> like GTORN1, 
C       relink LCFUTILS
C
C
C-- F77LCF      PCZ.F77MLCF2.FORT                               27/08/86    PRE
C
C SUBROUTINE 'SLLCF2'
C ===================
C
C THIS SUBROUTINE OPENS AN LCF FILE AND READS THE HEADER RECORDS.
C A CHECK IS MADE TO SEE WHETHER THE SPECIFIED COLUMN LABELS ARE
C PRESENT OR NOT. (NO ASSIGNMENTS ARE READ)
C
      SUBROUTINE SLLCF2(IUN,FILNAM,NL,LOOK,LCOL,IPRINT,NCOL,CELL)
C
C PARAMETERS
C
C         IUN (I)   UNIT NUMBER FOR THE INPUT FILE (OR EQUIVALENT IF
C                   NON-FORTRAN I/O IS USED)
C      FILNAM (I)   LOGICAL FILE NAME (UP TO 8 CHARACTERS)
C          NL (I)   THE NUMBER OF CHARACTERS IN THE ARRAY 'LOOK' WHICH
C                   CONTAINS THE NAMES OF STANDARD COLUMN LABELS WHICH
C                   ARE TO BE LOOKED FOR.
C        LOOK (I)   CHARACTER ARRAY CONTAINING THE COLUMN LABELS
C        LCOL (I/O) THIS ARRAY RETURNS THE POSITIONS OF THE REQUESTED
C                   DATA ITEMS. ON ENTRY TO THE SUBROUTINE THE ENTRIES
C                   IN 'LCOL' MUST BE SET TO 0 FOR OPTIONAL COLUMNS
C                   AND .LT. ZERO FOR COMPULSORY ONES. (COLUMN NUMBERS
C                   OF 0 ARE RETURNED FOR ABSENT OPTIONAL COLUMNS)
C      IPRINT (I)   FLAG =.TRUE.  PRINT (DEFAULT UNIT=6) THE CELL
C                                 DIMENSIONS, LABELS AND TITLE
C                                 INFORMATION AS READ FROM THE FILE
C                                 HEADER.
C                        =.FALSE. DO NOT PRINT THESE DETAILS
C       NCOLS (O)   RETURNS THE NUMBER OF COLUMNS OF REFLECTION
C                   DATA IN THE FILE
C        CELL (O)   6 WORD ARRAY RETURNING THE CELL DIMENSIONS
C                   IN ANGSTROMS AND DEGREES
C
C SPECIFICATION STATEMENTS
C
      LOGICAL IPRINT,RD
      CHARACTER*(*) FILNAM
      CHARACTER*1 ARRAYN(1000),LOOK(*)
      CHARACTER*2 BLANK
      DIMENSION LCOL(*),CELL(6)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT
      COMMON /LCF2FN/FILIN,FILOUT
      SAVE /LCF2/,/LCF2AR/,/LCF2WK/,/LCF2FN/
      DATA BLANK/'  '/
C
C OPEN INPUT FILE AND READ HEADER RECORDS
C
      LFAIL=0
      IDDN=IUN
      FILIN=FILNAM
      CALL RHLCF2(2,BLANK,LCOL,IPRINT)
      DO 5 I=1,6
      CELL(I)=CELLN(I)
5     CONTINUE
      NCOL=NCIN
      IF(NCIN.GT.100)GO TO 810
      IF(NL.LE.0)RETURN
C
C FIND THE NUMBER OF COLUMN LABELS IN 'LOOK' AND IN HEADER
C
      CALL LCFITM(ARRAYN,LABELN,NLAB)
      CALL LCFITM(LOOK,NL,NLOOK)
C
C SEARCH FOR REQUESTED COLUMN LABELS
C
      DO 20 J=1,NLOOK
      CALL LCFLBL(J,LOOK,NL,L1,L2,*20)
      DO 10 I=1,NLAB
      CALL LCFLBL(I,ARRAYN,LABELN,L3,L4,*10)
      IF(LCFCMP(LOOK,L1,L2,ARRAYN,L3,L4).EQ.1)GO TO 15
10    CONTINUE
C
C NO MATCH FOR THIS COLUMN
C
      IF(LCOL(J).EQ.0)GO TO 20
      WRITE(IOUT,2001)
      WRITE(IOUT,2002)J,(LOOK(L),L=L1,L2)
      LFAIL=LFAIL+1
      GO TO 20
C
C LABEL FOUND
C
15    LCOL(J)=I
C
C END OF LABELS LOOP
C
20    CONTINUE
C Setup things in common for RDLCF1
      RD=.TRUE.
      DO 30 J=1,NLOOK
      IPOINT(J)=LCOL(J)
30    CONTINUE
C
      IF(LFAIL.EQ.0)RETURN
      GO TO 800
C
C ERROR CONDITIONS
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      WRITE(IOUT,2004)
          call ccperr(1,' stop in lcflib.for 90070')
810   WRITE(IOUT,2001)
      WRITE(IOUT,2005)
      WRITE(IOUT,2004)
          call ccperr(1,' stop in lcflib.for 90080')
C
C FORMAT STATEMENTS
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(/,' **LABEL NOT FOUND FOR COMPULSORY COLUMN',I3,
     * ' **: ',40A1)
2003  FORMAT(/,' **',I3,' MISSING COMPULSORY COLUMNS IN FILE**')
2004  FORMAT(/,' **PROGRAM TERMINATED**')
2005  FORMAT(/,' **NO. OF COLS IN LCF FILE',I4,' EXCEEDS MAX OF 100**')
      END
C
C SUBROUTINE 'SRLCF1'
C ===================
C
C THIS SUBROUTINE IS USED TO OPEN A STANDARD LCF FILE FOR READING. IT
C CALLS THE SUBROUTINE 'RHLCF1' WHICH READS THE HEADER INFORMATION FROM
C THE FILE AND IF REQUIRED READS (DEFAULT UNIT=5) THE LCF COLUMN
C ASSIGNMENTS FROM THE CONTROL DATA.
C
      SUBROUTINE SRLCF1(IUN,FILNAM,NL,LOOK,LOOKUP,IPRINT,NCOLS,CELL)
C
C PARAMETERS
C
C         IUN (I)   UNIT NUMBER FOR THE INPUT FILE (OR EQUIVALENT IF
C                   NON-FORTRAN I/O IS USED)
C      FILNAM (I)   LOGICAL FILE NAME (UP TO 8 CHARACTERS)
C          NL (I)   THE NUMBER OF CHARACTERS IN THE ARRAY 'LOOK' WHICH
C                   CONTAINS THE NAMES OF THE DATA ITEMS REQUIRED BY
C                   THE PROGRAM. NL MAY BE SET TO ZERO FOR RE-READING A
C                   FILE. -NL MAY BE GIVEN IF OPTIONAL COLUMN ASSIGN-
C                   MENTS ARE TO BE USED (SEE 'LOOKUP' BELOW)
C        LOOK (I)   CHARACTER ARRAY CONTAINING THE PROGRAM LABELS FOR
C                   THE DATA ITEMS REQUIRED BY THE PROGRAM. IF 'NL' IS
C                   ZERO THEN 'LOOK' IS IGNORED. IF 'LOOK' CONTAINS
C                   ONLY BLANKS THEN NO COLUMN ASSIGNMENTS ARE READ.
C      LOOKUP (I/O) THIS ARRAY RETURNS THE POSITIONS OF THE REQUESTED
C                   DATA ITEMS. IF 'NL' IS NEGATIVE THEN, ON ENTRY
C                   TO THE SUBROUTINE, THE ENTRIES IN 'LOOKUP' MUST
C                   BE SET TO 0 FOR OPTIONAL COLUMNS AND -1 FOR
C                   COMPULSORY COLUMNS. IF NL > 0 THEN ALL COLUMNS ARE
C                   TREATED AS COMPULSORY.
C      IPRINT (I)   FLAG =.TRUE.  PRINT (DEFAULT UNIT=6) THE CELL
C                                 DIMENSIONS, LABELS AND TITLE
C                                 INFORMATION AS READ FROM THE FILE
C                                 HEADER.
C                        =.FALSE. DO NOT PRINT THESE DETAILS
C       NCOLS (O)   RETURNS THE NUMBER OF COLUMNS OF REFLECTION
C                   DATA IN THE FILE
C        CELL (O)   6 WORD ARRAY RETURNING THE CELL DIMENSIONS
C                   IN ANGSTROMS AND DEGREES
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD,IPRINT
      CHARACTER*(*) FILNAM
      CHARACTER*1 ARRAYN(1000),LOOK(*)
      DIMENSION LOOKUP(*),CELL(6)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT
      COMMON /LCF1FN/FILIN,FILOUT
      SAVE /LCF1/,/LCF1AR/,/LCF1WK/,/LCF1FN/
C
C CODE
C
      IDDN=IUN
      FILIN=FILNAM
      CALL RHLCF1(NL,LOOK,LOOKUP,IPRINT)
      NCOLS=NCIN
      DO 10 I=1,6
      CELL(I)=CELLN(I)
10    CONTINUE
      RETURN
      END
C
C SUBROUTINE 'SRLCF2'
C ===================
C
C THIS SUBROUTINE IS USED TO OPEN A STANDARD LCF FILE FOR READING. IT
C CALLS THE SUBROUTINE 'RHLCF2' WHICH READS THE HEADER INFORMATION FROM
C THE FILE AND IF REQUIRED READS (DEFAULT UNIT=5) THE LCF COLUMN
C ASSIGNMENTS FROM THE CONTROL DATA.
C
      SUBROUTINE SRLCF2(IUN,FILNAM,NL,LOOK,LOOKUP,IPRINT,NCOLS,CELL)
C
C PARAMETERS
C
C         IUN (I)   UNIT NUMBER FOR THE INPUT FILE (OR EQUIVALENT IF
C                   NON-FORTRAN I/O IS USED)
C      FILNAM (I)   LOGICAL FILE NAME (UP TO 8 CHARACTERS)
C          NL (I)   THE NUMBER OF CHARACTERS IN THE ARRAY 'LOOK' WHICH
C                   CONTAINS THE NAMES OF THE DATA ITEMS REQUIRED BY
C                   THE PROGRAM. NL MAY BE SET TO ZERO FOR RE-READING A
C                   FILE. -NL MAY BE GIVEN IF OPTIONAL COLUMN ASSIGN-
C                   MENTS ARE TO BE USED (SEE 'LOOKUP' BELOW)
C        LOOK (I)   CHARACTER ARRAY CONTAINING THE PROGRAM LABELS FOR
C                   THE DATA ITEMS REQUIRED BY THE PROGRAM. IF 'NL' IS
C                   ZERO THEN 'LOOK' IS IGNORED. IF 'LOOK' CONTAINS
C                   ONLY BLANKS THEN NO COLUMN ASSIGNMENTS ARE READ.
C      LOOKUP (I/O) THIS ARRAY RETURNS THE POSITIONS OF THE REQUESTED
C                   DATA ITEMS. IF 'NL' IS NEGATIVE THEN, ON ENTRY
C                   TO THE SUBROUTINE, THE ENTRIES IN 'LOOKUP' MUST
C                   BE SET TO 0 FOR OPTIONAL COLUMNS AND -1 FOR
C                   COMPULSORY COLUMNS. IF NL > 0 THEN ALL COLUMNS ARE
C                   TREATED AS COMPULSORY.
C      IPRINT (I)   FLAG =.TRUE.  PRINT (DEFAULT UNIT=6) THE CELL
C                                 DIMENSIONS, LABELS AND TITLE
C                                 INFORMATION AS READ FROM THE FILE
C                                 HEADER.
C                        =.FALSE. DO NOT PRINT THESE DETAILS
C       NCOLS (O)   RETURNS THE NUMBER OF COLUMNS OF REFLECTION
C                   DATA IN THE FILE
C        CELL (O)   6 WORD ARRAY RETURNING THE CELL DIMENSIONS
C                   IN ANGSTROMS AND DEGREES
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD,IPRINT
      CHARACTER*(*) FILNAM
      CHARACTER*1 ARRAYN(1000),LOOK(*)
      DIMENSION LOOKUP(*),CELL(6)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      CHARACTER*40 FILIN,FILOUT
      COMMON /LCF2FN/FILIN,FILOUT
      SAVE /LCF2/,/LCF2AR/,/LCF2WK/,/LCF2FN/
C
C CODE
C
      IDDN=IUN
      FILIN=FILNAM
      CALL RHLCF2(NL,LOOK,LOOKUP,IPRINT)
      NCOLS=NCIN
      DO 10 I=1,6
      CELL(I)=CELLN(I)
10    CONTINUE
      RETURN
      END
C
C SUBROUTINE 'TWLCF1'
C ===================
C
C WRITE A REFLECTION DATA RECORD CHECKING THAT NO ABSOLUTE VALUE
C IS GREATER THAN 32767
C
      SUBROUTINE TWLCF1(IDATA,*)
C
C PARAMETERS
C
C       IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C
C RETURN 1  ERROR RETURN IF A VALUE IS OUT OF RANGE
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      DIMENSION IDATA(NCOUT)
      SAVE /LCF1WK/
      DO 10 N=1,NCOUT
      IF(IABS(IDATA(N)).GT.32767)RETURN 1
10    CONTINUE
      CALL WLCF1(IDATA)
      RETURN
      END
C
C SUBROUTINE 'TWLCF2'
C ===================
C
C WRITE A REFLECTION DATA RECORD CHECKING THAT NO ABSOLUTE VALUE
C IS GREATER THAN 32767
C
      SUBROUTINE TWLCF2(IDATA,*)
C
C PARAMETERS
C
C       IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C
C RETURN 1  ERROR RETURN IF A VALUE IS OUT OF RANGE
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      DIMENSION IDATA(NCOUT)
      SAVE /LCF2WK/
      DO 10 N=1,NCOUT
      IF(IABS(IDATA(N)).GT.32767)RETURN 1
10    CONTINUE
      CALL WLCF2(IDATA)
      RETURN
      END
C
C SUBROUTINE 'WHLCF1'
C ====================
C
C THIS SUBROUTINE IS USED TO WRITE THE HEADER INFORMATION TO AN
C LCF FILE.
C
      SUBROUTINE WHLCF1(IDATA)
C
C PARAMETERS
C
C       IDATA (I)   DUMMY WORK ARRAY (RETAINED FOR COMPATIBILITY WITH
C                   ORIGINAL LCF ROUTINES.
C
C BEFORE CALLING THE ROUTINE THE FOLLOWING ITEMS MUST BE SET UP
C IN THE COMMON /LCF1/
C
C        IDDN  UNIT NO. OF OUTPUT FILE
C       LTITN  LENGTH OF TITLE INFORMATION
C      LABELN  LENGTH OF LABEL INFORMATION
C       CELLN  CELL DIMENSIONS (A B C ALPHA BETA GAMMA)
C      ARRAYN  THIS MUST HOLD THE REQUIRED TITLE AND LABELS INFORMATION
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD,RPT
      DIMENSION IDATA(*)
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1AR/ARRAYN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1/,/LCF1AR/,/LCF1WK/
      CALL BADLCF
C
C GET NUMBER OF COLUMNS FROM THE NUMBER OF LABELS
C
      CALL LCFITM(ARRAYN,LABELN,NCOL)
      IF(NCOL.LT.6)GO TO 800
      IF(NCOL.GT.100)GO TO 810
      NCOUT=NCOL
C
C TEST FOR REPEATED LABELS
C
      RPT=.FALSE.
      I=0
130   I=I+1
      CALL LCFLBL(I,ARRAYN,LABELN,M1,M2,*150)
      J=I
140   J=J+1
      CALL LCFLBL(J,ARRAYN,LABELN,M3,M4,*130)
      IF(LCFCMP(ARRAYN,M1,M2,ARRAYN,M3,M4).EQ.0)GO TO 140
      RPT=.TRUE.
      GO TO 820
150   IF(RPT)GO TO 900
C
C ENSURE THAT AT LEAST ONE CHARACTER OF TITLE PRESENT
C
      IF(LTITN.GT.0)GO TO 200
      LTITN=1
      ARRAYN(LABELN+1)=' '
C
C OPEN FILE
C
200   CALL LCF1OW(*850)
C
C WRITE HEADER RECORDS
C
      CALL HWLCF1
      RETURN
C
C ERROR CONDITIONS
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      GO TO 900
810   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      GO TO 900
820   WRITE(IOUT,2001)
      WRITE(IOUT,2004)(ARRAYN(M),M=M1,M2)
      GO TO 130
850   WRITE(IOUT,2001)
      WRITE(IOUT,2005)IUNOUT
900   WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 90080')
C
C FORMAT STATEMENTS
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(' **CANNOT OPEN FILE WITH LESS THAN 6 COLUMNS**')
2003  FORMAT(' **MAXIMUM NUMBER OF COLUMNS IS 100**')
2004  FORMAT(' **REPEATED LABEL** :',(1X,50A1))
2005  FORMAT(' **ERROR ON OPENING LCF FILE ON UNIT',I3,' **')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'WHLCF2'
C ====================
C
C THIS SUBROUTINE IS USED TO WRITE THE HEADER INFORMATION TO AN
C LCF FILE.
C
      SUBROUTINE WHLCF2(IDATA)
C
C PARAMETERS
C
C       IDATA (I)   DUMMY WORK ARRAY (RETAINED FOR COMPATIBILITY WITH
C                   ORIGINAL LCF ROUTINES.
C
C BEFORE CALLING THE ROUTINE THE FOLLOWING ITEMS MUST BE SET UP
C IN THE COMMON /LCF2/
C
C        IDDN  UNIT NO. OF OUTPUT FILE
C       LTITN  LENGTH OF TITLE INFORMATION
C      LABELN  LENGTH OF LABEL INFORMATION
C       CELLN  CELL DIMENSIONS (A B C ALPHA BETA GAMMA)
C      ARRAYN  THIS MUST HOLD THE REQUIRED TITLE AND LABELS INFORMATION
C
C SPECIFICATION STATEMENTS
C
      LOGICAL RD,RPT
      DIMENSION IDATA(*)
      CHARACTER*1 ARRAYN(1000)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2AR/ARRAYN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2/,/LCF2AR/,/LCF2WK/
      CALL BADLCF
C
C GET NUMBER OF COLUMNS FROM THE NUMBER OF LABELS
C
      CALL LCFITM(ARRAYN,LABELN,NCOL)
      IF(NCOL.LT.6)GO TO 800
      IF(NCOL.GT.100)GO TO 810
      NCOUT=NCOL
C
C TEST FOR REPEATED LABELS
C
      RPT=.FALSE.
      I=0
130   I=I+1
      CALL LCFLBL(I,ARRAYN,LABELN,M1,M2,*150)
      J=I
140   J=J+1
      CALL LCFLBL(J,ARRAYN,LABELN,M3,M4,*130)
      IF(LCFCMP(ARRAYN,M1,M2,ARRAYN,M3,M4).EQ.0)GO TO 140
      RPT=.TRUE.
      GO TO 820
150   IF(RPT)GO TO 900
C
C ENSURE THAT AT LEAST ONE CHARACTER OF TITLE PRESENT
C
      IF(LTITN.GT.0)GO TO 200
      LTITN=1
      ARRAYN(LABELN+1)=' '
C
C OPEN FILE
C
200   CALL LCF2OW(*850)
C
C WRITE HEADER RECORDS
C
      CALL HWLCF2
      RETURN
C
C ERROR CONDITIONS
C
800   WRITE(IOUT,2001)
      WRITE(IOUT,2002)
      GO TO 900
810   WRITE(IOUT,2001)
      WRITE(IOUT,2003)
      GO TO 900
820   WRITE(IOUT,2001)
      WRITE(IOUT,2004)(ARRAYN(M),M=M1,M2)
      GO TO 130
850   WRITE(IOUT,2001)
      WRITE(IOUT,2005)IUNOUT
900   WRITE(IOUT,2010)
          call ccperr(1,' stop in lcflib.for 90077')
C
C FORMAT STATEMENTS
C
2001  FORMAT(/,' **LCF ERROR**')
2002  FORMAT(' **CANNOT OPEN FILE WITH LESS THAN 6 COLUMNS**')
2003  FORMAT(' **MAXIMUM NUMBER OF COLUMNS IS 100**')
2004  FORMAT(' **REPEATED LABEL** :',(1X,50A1))
2005  FORMAT(' **ERROR ON OPENING LCF FILE ON UNIT',I3,' **')
2010  FORMAT(/,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'WLCF1'
C ==================
C
C THIS SUBROUTINE WRITES A REFLECTION DATA RECORD
C
C ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
      SUBROUTINE WLCF1(IDATA)
C
C PARAMETERS
C
C      IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      INTEGER*2 LDATA
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      COMMON /LCF1RW/LDATA(100)
      DIMENSION IDATA(NCOUT)
      SAVE /LCF1WK/,/LCF1RW/
      CALL BADLCF
      DO 10 I=1,NCOUT
      LDATA(I)=IDATA(I)
10    CONTINUE
      CALL WWLCF1(LDATA)
      RETURN
      END
C
C SUBROUTINE 'WLCF2'
C ==================
C
C THIS SUBROUTINE WRITES A REFLECTION DATA RECORD
C
C ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
      SUBROUTINE WLCF2(IDATA)
C
C PARAMETERS
C
C      IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      INTEGER*2 LDATA
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      COMMON /LCF2RW/LDATA(100)
      DIMENSION IDATA(NCOUT)
      SAVE /LCF2WK/,/LCF2RW/
      CALL BADLCF
      DO 10 I=1,NCOUT
      LDATA(I)=IDATA(I)
10    CONTINUE
      CALL WWLCF2(LDATA)
      RETURN
      END
C
C
      SUBROUTINE WTLCF1(IX,TITLE)
C     ===========================
C
C Subroutine to write batch title to output lcf file
C
C
C---- Parameters
C
C          IX (I)   BATCH NUMBER
C       TITLE (I)   CHARACTER ARRAY (72 CHARACTERS) HOLDING BATCH
C                   TITLE
C
C
C---- Specification statements
C
      CHARACTER*1 TITLE(72)
      LOGICAL RD
      COMMON /LCF1/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF1/,/LCF1WK/
      CALL BADLCF
C
C---- Write batch header records
C
      DO 5 I=1,4
      KDATA(I)=-32750
5     CONTINUE
      KDATA(5)=IX
      KDATA(7)=72
      IF(NCOUT.LT.8)GO TO 800
      N1=8
      LL=0
      ISEQ=0
10    ISEQ=ISEQ+1
      KDATA(6)=ISEQ
      CALL CHLCF1(KDATA,N1,NCOUT,TITLE,72,LL,2,*50)
      CALL WLCF1(KDATA)
      N1=7
      GO TO 10
50    RETURN
C
C---- Error conditions
C
800   WRITE(IOUT,2001)
          call ccperr(1,' stop in lcflib.for 8000')
C
C---- Format statements
C
2001  FORMAT(/,' **LCF ERROR**',
     *//,' **FILE MUST HAVE AT LEAST 8 COLS FOR BATCH TITLE**',
     *//,' **PROGRAM TERMINATED**')
      END
C
C SUBROUTINE 'WTLCF2'
C ===================
C
C SUBROUTINE TO WRITE BATCH TITLE TO OUTPUT LCF FILE
C
      SUBROUTINE WTLCF2(IX,TITLE)
C
C PARAMETERS
C
C          IX (I)   BATCH NUMBER
C       TITLE (I)   CHARACTER ARRAY (72 CHARACTERS) HOLDING BATCH
C                   TITLE
C
C
C SPECIFICATION STATEMENTS
C
      CHARACTER*1 TITLE(72)
      COMMON /LCF2/IDDN,MAXDN,CELLN(6),LRECLN,LTITN,LABELN
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /LCF2/,/LCF2WK/
      CALL BADLCF
C
C WRITE BATCH HEADER RECORDS
C
      DO 5 I=1,4
      KDATA(I)=-32750
5     CONTINUE
      KDATA(5)=IX
      KDATA(7)=72
      IF(NCOUT.LT.8)GO TO 800
      N1=8
      LL=0
      ISEQ=0
10    ISEQ=ISEQ+1
      KDATA(6)=ISEQ
      CALL CHLCF2(KDATA,N1,NCOUT,TITLE,72,LL,2,*50)
      CALL WLCF2(KDATA)
      N1=7
      GO TO 10
50    RETURN
C
C ERROR CONDITIONS
C
800   WRITE(IOUT,2001)
          call ccperr(1,' stop in lcflib.for 8001')
C
C FORMAT STATEMENTS
C
2001  FORMAT(/,' **LCF ERROR**',
     *//,' **FILE MUST HAVE AT LEAST 8 COLS FOR BATCH TITLE**',
     *//,' **PROGRAM TERMINATED**')
      END
C
C
      SUBROUTINE WTORN1(IBATCH,NC)
C     ============================
C
C This subroutine writes a block or orientation data to an output
C lcf file from the common block 'orient'
C
C
C---- Parameters
C
C      IBATCH (I)   BATCH NUMBER
C          NC (I)   DUMMY
C
C---- Specification statements
C
      COMMON /ORIENT/ORDATA(200)
      INTEGER ORDATA
      LOGICAL RD
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /ORIENT/,/LCF1WK/
      CALL BADLCF
C
C---- Write orientation block
C
      NWORD=ORDATA(1)
      LL=0
      ISEQ=0
      DO 10 I=1,4
      KDATA(I)=-32740
10    CONTINUE
      KDATA(5)=IBATCH
20    ISEQ=ISEQ+1
      KDATA(6)=ISEQ
      CALL ORPAK1(KDATA,7,NCOUT,ORDATA,NWORD,LL,2,*30)
      CALL WLCF1(KDATA)
      GO TO 20
30    RETURN
      END
C
C
C SUBROUTINE 'WTORN2'
C ===================
C
C THIS SUBROUTINE WRITES A BLOCK OR ORIENTATION DATA TO AN OUTPUT
C LCF FILE FROM THE COMMON BLOCK 'ORIENT'
C
      SUBROUTINE WTORN2(IBATCH,NC)
C
C PARAMETERS
C
C      IBATCH (I)   BATCH NUMBER
C          NC (I)   DUMMY
C
C SPECIFICATION STATEMENTS
C
      COMMON /ORIENT/ORDATA(53)
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      SAVE /ORIENT/,/LCF2WK/
      CALL BADLCF
C
C WRITE ORIENTATION BLOCK
C
      NWORD=53
      LL=0
      ISEQ=0
      DO 10 I=1,4
      KDATA(I)=-32740
10    CONTINUE
      KDATA(5)=IBATCH
20    ISEQ=ISEQ+1
      KDATA(6)=ISEQ
      CALL ORPAK2(KDATA,7,NCOUT,ORDATA,NWORD,LL,2,*30)
      CALL WLCF2(KDATA)
      GO TO 20
30    RETURN
      END
C
C SUBROUTINE 'WWLCF1'
C ===================
C
C THIS SUBROUTINE WRITES A REFLECTION DATA RECORD (FROM INTEGER*2
C ARRAY)
C
C ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
      SUBROUTINE WWLCF1(IDATA)
C
C PARAMETERS
C
C      IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C                  (INTEGER*2)
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      COMMON /LCF1WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      INTEGER*2 IDATA(NCOUT)
      SAVE /LCF1WK/
C
      CALL QWRITE(IUNOUT,IDATA,NCOUT)
      RETURN
C
C FORMAT STATEMENTS
C
1000  FORMAT(100A2)
      END
C
C SUBROUTINE 'WWLCF2'
C ===================
C
C THIS SUBROUTINE WRITES A REFLECTION DATA RECORD (FROM INTEGER*2
C ARRAY)
C
C ****THIS SUBROUTINE CONTAINS MACHINE DEPENDENT CODE****
C
      SUBROUTINE WWLCF2(IDATA)
C
C PARAMETERS
C
C      IDATA (I)   ARRAY CONTAINING REFLECTION DATA ITEMS
C                  (INTEGER*2)
C
C SPECIFICATION STATEMENTS AND CODE
C
      LOGICAL RD
      COMMON /LCF2WK/RD,IN,IOUT,LBUF,IUNIN,NCIN,IUNOUT,NCOUT,
     *               IPOINT(100),NLOOK,KDATA(100)
      INTEGER*2 IDATA(NCOUT)
      SAVE /LCF2WK/
C
      CALL BADLCF
      CALL QWRITE(IUNOUT,IDATA,NCOUT)
      RETURN
C
C FORMAT STATEMENTS
C
1000  FORMAT(100A2)
      END

      SUBROUTINE BADLCF
C     stop on attempts to write LCF 
      EXTERNAL CCPERR
      CALL CCPERR(1,
     +     'Ideologially unsound attempt to WRITE an LCF file')
      END
